diff options
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Math')
11 files changed, 6997 insertions, 3847 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigFloat.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigFloat.pm index f1d7a1a0a0..66300a4928 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigFloat.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigFloat.pm @@ -16,10 +16,12 @@ use 5.006001; use strict; use warnings; -use Carp qw< carp croak >; -use Math::BigInt (); +use Carp qw< carp croak >; +use Scalar::Util qw< blessed >; +use Math::BigInt qw< >; -our $VERSION = '1.999818'; +our $VERSION = '1.999837'; +$VERSION =~ tr/_//d; require Exporter; our @ISA = qw/Math::BigInt/; @@ -58,21 +60,21 @@ use overload # overload key: assign - '+=' => sub { $_[0]->badd($_[1]); }, + '+=' => sub { $_[0] -> badd($_[1]); }, - '-=' => sub { $_[0]->bsub($_[1]); }, + '-=' => sub { $_[0] -> bsub($_[1]); }, - '*=' => sub { $_[0]->bmul($_[1]); }, + '*=' => sub { $_[0] -> bmul($_[1]); }, - '/=' => sub { scalar $_[0]->bdiv($_[1]); }, + '/=' => sub { scalar $_[0] -> bdiv($_[1]); }, - '%=' => sub { $_[0]->bmod($_[1]); }, + '%=' => sub { $_[0] -> bmod($_[1]); }, - '**=' => sub { $_[0]->bpow($_[1]); }, + '**=' => sub { $_[0] -> bpow($_[1]); }, - '<<=' => sub { $_[0]->blsft($_[1]); }, + '<<=' => sub { $_[0] -> blsft($_[1]); }, - '>>=' => sub { $_[0]->brsft($_[1]); }, + '>>=' => sub { $_[0] -> brsft($_[1]); }, # 'x=' => sub { }, @@ -194,7 +196,7 @@ use overload '0+' => sub { $_[0] -> numify(); }, - '=' => sub { $_[0]->copy(); }, + '=' => sub { $_[0] -> copy(); }, ; @@ -259,8 +261,7 @@ BEGIN { $rnd_mode = 'even'; tie $rnd_mode, 'Math::BigFloat'; - # we need both of them in this package: - *as_int = \&as_number; + *as_number = \&as_int; } sub DESTROY { @@ -270,7 +271,6 @@ sub DESTROY { sub AUTOLOAD { # make fxxx and bxxx both work by selectively mapping fxxx() to MBF::bxxx() my $name = $AUTOLOAD; - $name =~ s/(.*):://; # split package my $c = $1 || __PACKAGE__; no strict 'refs'; @@ -284,7 +284,8 @@ sub AUTOLOAD { # delayed load of Carp and avoid recursion croak("Can't call $c\-\>$name, not a valid method"); } - # try one level up, but subst. bxxx() for fxxx() since MBI only got bxxx() + # try one level up, but subst. bxxx() for fxxx() since MBI only got + # bxxx() $name =~ s/^f/b/; return &{"Math::BigInt"."::$name"}(@_); } @@ -351,7 +352,8 @@ sub config { ############################################################################### sub new { - # Create a new Math::BigFloat object from a string or another bigfloat object. + # Create a new Math::BigFloat object from a string or another bigfloat + # object. # _e: exponent # _m: mantissa # sign => ("+", "-", "+inf", "-inf", or "NaN") @@ -360,193 +362,212 @@ sub new { my $selfref = ref $self; my $class = $selfref || $self; - my ($wanted, @r) = @_; + # Make "require" work. - # avoid numify-calls by not using || on $wanted! + $class -> import() if $IMPORT == 0; - unless (defined $wanted) { - #carp("Use of uninitialized value in new"); - return $self->bzero(@r); - } + # Although this use has been discouraged for more than 10 years, people + # apparently still use it, so we still support it. - # Using $wanted->isa("Math::BigFloat") here causes a 'Deep recursion on - # subroutine "Math::BigFloat::as_number"' in some tests. Fixme! + return $class -> bzero() unless @_; - if (UNIVERSAL::isa($wanted, 'Math::BigFloat')) { - my $copy = $wanted -> copy(); - if ($selfref) { # if new() called as instance method - %$self = %$copy; - } else { # if new() called as class method - $self = $copy; - } - return $copy; + my ($wanted, @r) = @_; + + if (!defined($wanted)) { + #if (warnings::enabled("uninitialized")) { + # warnings::warn("uninitialized", + # "Use of uninitialized value in new()"); + #} + return $class -> bzero(@r); } - $class->import() if $IMPORT == 0; # make require work + if (!ref($wanted) && $wanted eq "") { + #if (warnings::enabled("numeric")) { + # warnings::warn("numeric", + # q|Argument "" isn't numeric in new()|); + #} + #return $class -> bzero(@r); + return $class -> bnan(@r); + } - # If called as a class method, initialize a new object. + # Initialize a new object. $self = bless {}, $class unless $selfref; - # shortcut for bigints and its subclasses - if ((ref($wanted)) && $wanted -> can("as_number")) { - $self->{_m} = $wanted->as_number()->{value}; # get us a bigint copy - $self->{_e} = $LIB->_zero(); - $self->{_es} = '+'; - $self->{sign} = $wanted->sign(); - return $self->bnorm(); + # Math::BigFloat or subclass + + if (defined(blessed($wanted)) && $wanted -> isa($class)) { + + # Don't copy the accuracy and precision, because a new object should get + # them from the global configuration. + + $self -> {sign} = $wanted -> {sign}; + $self -> {_m} = $LIB -> _copy($wanted -> {_m}); + $self -> {_es} = $wanted -> {_es}; + $self -> {_e} = $LIB -> _copy($wanted -> {_e}); + $self = $self->round(@r) + unless @r >= 2 && !defined($r[0]) && !defined($r[1]); + return $self; } - # else: got a string or something masquerading as number (with overload) + # Shortcut for Math::BigInt and its subclasses. This should be improved. + + if (defined(blessed($wanted))) { + if ($wanted -> isa('Math::BigInt')) { + $self->{sign} = $wanted -> {sign}; + $self->{_m} = $LIB -> _copy($wanted -> {value}); + $self->{_es} = '+'; + $self->{_e} = $LIB -> _zero(); + return $self -> bnorm(); + } + + if ($wanted -> can("as_number")) { + $self->{sign} = $wanted -> sign(); + $self->{_m} = $wanted -> as_number() -> {value}; + $self->{_es} = '+'; + $self->{_e} = $LIB -> _zero(); + return $self -> bnorm(); + } + } + + # Shortcut for simple forms like '123' that have no trailing zeros. Trailing + # zeros would require a non-zero exponent. + + if ($wanted =~ + / ^ + \s* # optional leading whitespace + ( [+-]? ) # optional sign + 0* # optional leading zeros + ( [1-9] (?: [0-9]* [1-9] )? ) # significand + \s* # optional trailing whitespace + $ + /x) + { + return $downgrade -> new($1 . $2) if defined $downgrade; + $self->{sign} = $1 || '+'; + $self->{_m} = $LIB -> _new($2); + $self->{_es} = '+'; + $self->{_e} = $LIB -> _zero(); + $self = $self->round(@r) + unless @r >= 2 && !defined $r[0] && !defined $r[1]; + return $self; + } # Handle Infs. - if ($wanted =~ /^\s*([+-]?)inf(inity)?\s*\z/i) { - return $downgrade->new($wanted) if $downgrade; + if ($wanted =~ / ^ + \s* + ( [+-]? ) + inf (?: inity )? + \s* + \z + /ix) + { my $sgn = $1 || '+'; - $self->{sign} = $sgn . 'inf'; # set a default sign for bstr() - return $self->binf($sgn); + return $class -> binf($sgn, @r); } # Handle explicit NaNs (not the ones returned due to invalid input). - if ($wanted =~ /^\s*([+-]?)nan\s*\z/i) { - return $downgrade->new($wanted) if $downgrade; - $self = $class -> bnan(); - $self->round(@r) unless @r >= 2 && !defined $r[0] && !defined $r[1]; - return $self; + if ($wanted =~ / ^ + \s* + ( [+-]? ) + nan + \s* + \z + /ix) + { + return $class -> bnan(@r); } - # Handle hexadecimal numbers. We auto-detect hexadecimal numbers if they - # have a "0x" or "0X" prefix. + my @parts; - if ($wanted =~ /^\s*[+-]?0[Xx]/) { - $self = $class -> from_hex($wanted); - $self->round(@r) unless @r >= 2 && !defined $r[0] && !defined $r[1]; - return $self; - } + if ( + # Handle hexadecimal numbers. We auto-detect hexadecimal numbers if they + # have a "0x", "0X", "x", or "X" prefix, cf. CORE::oct(). + + $wanted =~ /^\s*[+-]?0?[Xx]/ and + @parts = $class -> _hex_str_to_flt_lib_parts($wanted) + + or - # Handle octal numbers. We auto-detect octal numbers if they have a "0" - # prefix and a binary exponent. + # Handle octal numbers. We auto-detect octal numbers if they have a + # "0o", "0O", "o", "O" prefix, cf. CORE::oct(). - if ($wanted =~ / - ^ - \s* + $wanted =~ /^\s*[+-]?0?[Oo]/ and + @parts = $class -> _oct_str_to_flt_lib_parts($wanted) - # sign - [+-]? + or - # prefix - 0 + # Handle binary numbers. We auto-detect binary numbers if they have a + # "0b", "0B", "b", or "B" prefix, cf. CORE::oct(). - # significand using the octal digits 0..7 - [0-7]+ (?: _ [0-7]+ )* - (?: - \. - (?: [0-7]+ (?: _ [0-7]+ )* )? - )? + $wanted =~ /^\s*[+-]?0?[Bb]/ and + @parts = $class -> _bin_str_to_flt_lib_parts($wanted) - # exponent (power of 2) using decimal digits - [Pp] - [+-]? - \d+ (?: _ \d+ )* + or - \s* - $ - /x) + # At this point, what is left are decimal numbers that aren't handled + # above and octal floating point numbers that don't have any of the + # "0o", "0O", "o", or "O" prefixes. First see if it is a decimal number. + + @parts = $class -> _dec_str_to_flt_lib_parts($wanted) + or + + # See if it is an octal floating point number. The extra check is + # included because _oct_str_to_flt_lib_parts() accepts octal numbers + # that don't have a prefix (this is needed to make it work with, e.g., + # from_oct() that don't require a prefix). However, Perl requires a + # prefix for octal floating point literals. For example, "1p+0" is not + # valid, but "01p+0" and "0__1p+0" are. + + $wanted =~ /^\s*[+-]?0_*\d/ and + @parts = $class -> _oct_str_to_flt_lib_parts($wanted)) { - $self = $class -> from_oct($wanted); - $self->round(@r) unless @r >= 2 && !defined $r[0] && !defined $r[1]; - return $self; - } + ($self->{sign}, $self->{_m}, $self->{_es}, $self->{_e}) = @parts; - # Handle binary numbers. We auto-detect binary numbers if they have a "0b" - # or "0B" prefix. + $self = $self->round(@r) + unless @r >= 2 && !defined($r[0]) && !defined($r[1]); - if ($wanted =~ /^\s*[+-]?0[Bb]/) { - $self = $class -> from_bin($wanted); - $self->round(@r) unless @r >= 2 && !defined $r[0] && !defined $r[1]; + return $downgrade -> new($self -> bdstr(), @r) + if defined($downgrade) && $self -> is_int(); return $self; } - # Shortcut for simple forms like '12' that have no trailing zeros. - if ($wanted =~ /^([+-]?)0*([1-9][0-9]*[1-9])$/) { - $self->{_e} = $LIB -> _zero(); - $self->{_es} = '+'; - $self->{sign} = $1 || '+'; - $self->{_m} = $LIB -> _new($2); - if (!$downgrade) { - $self->round(@r) unless @r >= 2 && !defined $r[0] && !defined $r[1]; - return $self; - } - } + # If we get here, the value is neither a valid decimal, binary, octal, or + # hexadecimal number. It is not an explicit Inf or a NaN either. - my ($mis, $miv, $mfv, $es, $ev) = Math::BigInt::_split($wanted); - if (!ref $mis) { - if ($_trap_nan) { - croak("$wanted is not a number initialized to $class"); - } + return $class -> bnan(@r); +} - return $downgrade->bnan() if $downgrade; +sub from_dec { + my $self = shift; + my $selfref = ref $self; + my $class = $selfref || $self; - $self->{_e} = $LIB->_zero(); - $self->{_es} = '+'; - $self->{_m} = $LIB->_zero(); - $self->{sign} = $nan; - } else { - # make integer from mantissa by adjusting exp, then convert to int - $self->{_e} = $LIB->_new($$ev); # exponent - $self->{_es} = $$es || '+'; - my $mantissa = "$$miv$$mfv"; # create mant. - $mantissa =~ s/^0+(\d)/$1/; # strip leading zeros - $self->{_m} = $LIB->_new($mantissa); # create mant. - - # 3.123E0 = 3123E-3, and 3.123E-2 => 3123E-5 - if (CORE::length($$mfv) != 0) { - my $len = $LIB->_new(CORE::length($$mfv)); - ($self->{_e}, $self->{_es}) = - _e_sub($self->{_e}, $len, $self->{_es}, '+'); - } - # we can only have trailing zeros on the mantissa if $$mfv eq '' - else { - # Use a regexp to count the trailing zeros in $$miv instead of - # _zeros() because that is faster, especially when _m is not stored - # in base 10. - my $zeros = 0; - $zeros = CORE::length($1) if $$miv =~ /[1-9](0*)$/; - if ($zeros != 0) { - my $z = $LIB->_new($zeros); - # turn '120e2' into '12e3' - $self->{_m} = $LIB->_rsft($self->{_m}, $z, 10); - ($self->{_e}, $self->{_es}) = - _e_add($self->{_e}, $z, $self->{_es}, '+'); - } - } - $self->{sign} = $$mis; + # Don't modify constant (read-only) objects. - # for something like 0Ey, set y to 0, and -0 => +0 - # Check $$miv for being '0' and $$mfv eq '', because otherwise _m could not - # have become 0. That's faster than to call $LIB->_is_zero(). - $self->{sign} = '+', $self->{_e} = $LIB->_zero() - if $$miv eq '0' and $$mfv eq ''; + return $self if $selfref && $self->modify('from_dec'); - if (!$downgrade) { - $self->round(@r) unless @r >= 2 && !defined $r[0] && !defined $r[1]; - return $self; - } - } + my $str = shift; + my @r = @_; - # if downgrade, inf, NaN or integers go down + # If called as a class method, initialize a new object. - if ($downgrade && $self->{_es} eq '+') { - if ($LIB->_is_zero($self->{_e})) { - return $downgrade->new($$mis . $LIB->_str($self->{_m})); - } - return $downgrade->new($self->bsstr()); + $self = bless {}, $class unless $selfref; + + if (my @parts = $class -> _dec_str_to_flt_lib_parts($str)) { + ($self->{sign}, $self->{_m}, $self->{_es}, $self->{_e}) = @parts; + + $self = $self->round(@r) + unless @r >= 2 && !defined($r[0]) && !defined($r[1]); + + return $downgrade -> new($self -> bdstr(), @r) + if defined($downgrade) && $self -> is_int(); + return $self; } - $self->bnorm(); - $self->round(@r) unless @r >= 2 && !defined $r[0] && !defined $r[1]; - return $self; + + return $self -> bnan(@r); } sub from_hex { @@ -556,88 +577,27 @@ sub from_hex { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('from_hex'); + return $self if $selfref && $self->modify('from_hex'); my $str = shift; + my @r = @_; # If called as a class method, initialize a new object. - $self = $class -> bzero() unless $selfref; - - if ($str =~ s/ - ^ - \s* - - # sign - ( [+-]? ) - - # optional "hex marker" - (?: 0? x )? - - # significand using the hex digits 0..9 and a..f - ( - [0-9a-fA-F]+ (?: _ [0-9a-fA-F]+ )* - (?: - \. - (?: [0-9a-fA-F]+ (?: _ [0-9a-fA-F]+ )* )? - )? - | - \. - [0-9a-fA-F]+ (?: _ [0-9a-fA-F]+ )* - ) - - # exponent (power of 2) using decimal digits - (?: - [Pp] - ( [+-]? ) - ( \d+ (?: _ \d+ )* ) - )? - - \s* - $ - //x) - { - my $s_sign = $1 || '+'; - my $s_value = $2; - my $e_sign = $3 || '+'; - my $e_value = $4 || '0'; - $s_value =~ tr/_//d; - $e_value =~ tr/_//d; - - # The significand must be multiplied by 2 raised to this exponent. - - my $two_expon = $class -> new($e_value); - $two_expon -> bneg() if $e_sign eq '-'; - - # If there is a dot in the significand, remove it and adjust the - # exponent according to the number of digits in the fraction part of - # the significand. Since the digits in the significand are in base 16, - # but the exponent is only in base 2, multiply the exponent adjustment - # value by log(16) / log(2) = 4. - - my $idx = index($s_value, '.'); - if ($idx >= 0) { - substr($s_value, $idx, 1) = ''; - $two_expon -= $class -> new(CORE::length($s_value)) - -> bsub($idx) - -> bmul("4"); - } + $self = bless {}, $class unless $selfref; - $self -> {sign} = $s_sign; - $self -> {_m} = $LIB -> _from_hex('0x' . $s_value); + if (my @parts = $class -> _hex_str_to_flt_lib_parts($str)) { + ($self->{sign}, $self->{_m}, $self->{_es}, $self->{_e}) = @parts; - if ($two_expon > 0) { - my $factor = $class -> new("2") -> bpow($two_expon); - $self -> bmul($factor); - } elsif ($two_expon < 0) { - my $factor = $class -> new("0.5") -> bpow(-$two_expon); - $self -> bmul($factor); - } + $self = $self->round(@r) + unless @r >= 2 && !defined($r[0]) && !defined($r[1]); + return $downgrade -> new($self -> bdstr(), @r) + if defined($downgrade) && $self -> is_int(); return $self; } - return $self->bnan(); + return $self -> bnan(@r); } sub from_oct { @@ -647,85 +607,27 @@ sub from_oct { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('from_oct'); + return $self if $selfref && $self->modify('from_oct'); my $str = shift; + my @r = @_; # If called as a class method, initialize a new object. - $self = $class -> bzero() unless $selfref; - - if ($str =~ s/ - ^ - \s* - - # sign - ( [+-]? ) - - # significand using the octal digits 0..7 - ( - [0-7]+ (?: _ [0-7]+ )* - (?: - \. - (?: [0-7]+ (?: _ [0-7]+ )* )? - )? - | - \. - [0-7]+ (?: _ [0-7]+ )* - ) - - # exponent (power of 2) using decimal digits - (?: - [Pp] - ( [+-]? ) - ( \d+ (?: _ \d+ )* ) - )? - - \s* - $ - //x) - { - my $s_sign = $1 || '+'; - my $s_value = $2; - my $e_sign = $3 || '+'; - my $e_value = $4 || '0'; - $s_value =~ tr/_//d; - $e_value =~ tr/_//d; - - # The significand must be multiplied by 2 raised to this exponent. - - my $two_expon = $class -> new($e_value); - $two_expon -> bneg() if $e_sign eq '-'; - - # If there is a dot in the significand, remove it and adjust the - # exponent according to the number of digits in the fraction part of - # the significand. Since the digits in the significand are in base 8, - # but the exponent is only in base 2, multiply the exponent adjustment - # value by log(8) / log(2) = 3. - - my $idx = index($s_value, '.'); - if ($idx >= 0) { - substr($s_value, $idx, 1) = ''; - $two_expon -= $class -> new(CORE::length($s_value)) - -> bsub($idx) - -> bmul("3"); - } + $self = bless {}, $class unless $selfref; - $self -> {sign} = $s_sign; - $self -> {_m} = $LIB -> _from_oct($s_value); + if (my @parts = $class -> _oct_str_to_flt_lib_parts($str)) { + ($self->{sign}, $self->{_m}, $self->{_es}, $self->{_e}) = @parts; - if ($two_expon > 0) { - my $factor = $class -> new("2") -> bpow($two_expon); - $self -> bmul($factor); - } elsif ($two_expon < 0) { - my $factor = $class -> new("0.5") -> bpow(-$two_expon); - $self -> bmul($factor); - } + $self = $self->round(@r) + unless @r >= 2 && !defined($r[0]) && !defined($r[1]); + return $downgrade -> new($self -> bdstr(), @r) + if defined($downgrade) && $self -> is_int(); return $self; } - return $self->bnan(); + return $self -> bnan(@r); } sub from_bin { @@ -735,85 +637,27 @@ sub from_bin { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('from_bin'); + return $self if $selfref && $self->modify('from_bin'); my $str = shift; + my @r = @_; # If called as a class method, initialize a new object. - $self = $class -> bzero() unless $selfref; - - if ($str =~ s/ - ^ - \s* - - # sign - ( [+-]? ) - - # optional "bin marker" - (?: 0? b )? - - # significand using the binary digits 0 and 1 - ( - [01]+ (?: _ [01]+ )* - (?: - \. - (?: [01]+ (?: _ [01]+ )* )? - )? - | - \. - [01]+ (?: _ [01]+ )* - ) - - # exponent (power of 2) using decimal digits - (?: - [Pp] - ( [+-]? ) - ( \d+ (?: _ \d+ )* ) - )? - - \s* - $ - //x) - { - my $s_sign = $1 || '+'; - my $s_value = $2; - my $e_sign = $3 || '+'; - my $e_value = $4 || '0'; - $s_value =~ tr/_//d; - $e_value =~ tr/_//d; - - # The significand must be multiplied by 2 raised to this exponent. - - my $two_expon = $class -> new($e_value); - $two_expon -> bneg() if $e_sign eq '-'; - - # If there is a dot in the significand, remove it and adjust the - # exponent according to the number of digits in the fraction part of - # the significand. - - my $idx = index($s_value, '.'); - if ($idx >= 0) { - substr($s_value, $idx, 1) = ''; - $two_expon -= $class -> new(CORE::length($s_value)) - -> bsub($idx); - } + $self = bless {}, $class unless $selfref; - $self -> {sign} = $s_sign; - $self -> {_m} = $LIB -> _from_bin('0b' . $s_value); + if (my @parts = $class -> _bin_str_to_flt_lib_parts($str)) { + ($self->{sign}, $self->{_m}, $self->{_es}, $self->{_e}) = @parts; - if ($two_expon > 0) { - my $factor = $class -> new("2") -> bpow($two_expon); - $self -> bmul($factor); - } elsif ($two_expon < 0) { - my $factor = $class -> new("0.5") -> bpow(-$two_expon); - $self -> bmul($factor); - } + $self = $self->round(@r) + unless @r >= 2 && !defined($r[0]) && !defined($r[1]); + return $downgrade -> new($self -> bdstr(), @r) + if defined($downgrade) && $self -> is_int(); return $self; } - return $self->bnan(); + return $self -> bnan(@r); } sub from_ieee754 { @@ -823,13 +667,14 @@ sub from_ieee754 { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('from_ieee754'); + return $self 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 + my @r = @_; # rounding parameters, if any if ($format =~ /^binary(\d+)\z/) { $k = $1; @@ -890,7 +735,7 @@ sub from_ieee754 { # The maximum exponent, minimum exponent, and exponent bias. - my $emax = Math::BigInt -> new(2) -> bpow($w - 1) -> bdec(); + my $emax = Math::BigFloat -> new(2) -> bpow($w - 1) -> bdec(); my $emin = 1 - $emax; my $bias = $emax; @@ -898,7 +743,7 @@ sub from_ieee754 { unless (defined $in) { carp("Input is undefined"); - return $self -> bzero(); + return $self -> bzero(@r); } # Make sure input string is a string of zeros and ones. @@ -927,7 +772,7 @@ sub from_ieee754 { my $x; - $expo -> bsub($bias); # subtract bias + $expo = $expo -> bsub($bias); # subtract bias if ($expo < $emin) { # zero and subnormals if ($mant == 0) { # zero @@ -935,8 +780,8 @@ sub from_ieee754 { } 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 '-'; + $x = $x -> bpow($bias + $t - 1) -> bmul($mant); + $x = $x -> bneg() if $sign eq '-'; } } @@ -944,7 +789,7 @@ sub from_ieee754 { if ($mant == 0) { # inf $x = $class -> binf($sign); } else { # nan - $x = $class -> bnan(); + $x = $class -> bnan(@r); } } @@ -953,12 +798,12 @@ sub from_ieee754 { if ($expo < $t) { # compute (1/$b)**(N) rather than ($b)**(-N) $x = $class -> new("0.5"); # 1/$b - $x -> bpow($t - $expo) -> bmul($mant); + $x = $x -> bpow($t - $expo) -> bmul($mant); } else { $x = $class -> new(2); - $x -> bpow($expo - $t) -> bmul($mant); + $x = $x -> bpow($expo - $t) -> bmul($mant); } - $x -> bneg() if $sign eq '-'; + $x = $x -> bneg() if $sign eq '-'; } if ($selfref) { @@ -969,7 +814,10 @@ sub from_ieee754 { } else { $self = $x; } - return $self; + + return $downgrade -> new($self -> bdstr(), @r) + if defined($downgrade) && $self -> is_int(); + return $self -> round(@r); } croak("The format '$format' is not yet supported."); @@ -978,9 +826,12 @@ sub from_ieee754 { sub bzero { # create/assign '+0' - if (@_ == 0) { - #carp("Using bone() as a function is deprecated;", - # " use bone() as a method instead"); + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) + { + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; unshift @_, __PACKAGE__; } @@ -989,7 +840,18 @@ sub bzero { my $class = $selfref || $self; $self->import() if $IMPORT == 0; # make require work - return if $selfref && $self->modify('bzero'); + + # Don't modify constant (read-only) objects. + + return $self if $selfref && $self->modify('bzero'); + + # Get the rounding parameters, if any. + + my @r = @_; + + return $downgrade -> bzero(@r) if defined $downgrade; + + # If called as a class method, initialize a new object. $self = bless {}, $class unless $selfref; @@ -1002,11 +864,13 @@ sub bzero { # parameters are given, and if called as a class method initialize the new # instance with the class variables. - if (@_) { + #return $self -> round(@r); # this should work, but doesnt; fixme! + + if (@r) { croak "can't specify both accuracy and precision" - if @_ >= 2 && defined $_[0] && defined $_[1]; - $self->{_a} = $_[0]; - $self->{_p} = $_[1]; + if @r >= 2 && defined($r[0]) && defined($r[1]); + $self->{_a} = $r[0]; + $self->{_p} = $r[1]; } else { unless($selfref) { $self->{_a} = $class -> accuracy(); @@ -1020,9 +884,12 @@ sub bzero { sub bone { # Create or assign '+1' (or -1 if given sign '-'). - if (@_ == 0 || (defined($_[0]) && ($_[0] eq '+' || $_[0] eq '-'))) { - #carp("Using bone() as a function is deprecated;", - # " use bone() as a method instead"); + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) + { + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; unshift @_, __PACKAGE__; } @@ -1031,10 +898,26 @@ sub bone { my $class = $selfref || $self; $self->import() if $IMPORT == 0; # make require work - return if $selfref && $self->modify('bone'); - my $sign = shift; - $sign = defined $sign && $sign =~ /^\s*-/ ? "-" : "+"; + # Don't modify constant (read-only) objects. + + return $self if $selfref && $self->modify('bone'); + + return $downgrade -> bone(@_) if defined $downgrade; + + # Get the sign. + + my $sign = '+'; # default is to return +1 + if (defined($_[0]) && $_[0] =~ /^\s*([+-])\s*$/) { + $sign = $1; + shift; + } + + # Get the rounding parameters, if any. + + my @r = @_; + + # If called as a class method, initialize a new object. $self = bless {}, $class unless $selfref; @@ -1047,9 +930,11 @@ sub bone { # parameters are given, and if called as a class method initialize the new # instance with the class variables. - if (@_) { + #return $self -> round(@r); # this should work, but doesnt; fixme! + + if (@r) { croak "can't specify both accuracy and precision" - if @_ >= 2 && defined $_[0] && defined $_[1]; + if @r >= 2 && defined($r[0]) && defined($r[1]); $self->{_a} = $_[0]; $self->{_p} = $_[1]; } else { @@ -1065,11 +950,12 @@ sub bone { sub binf { # create/assign a '+inf' or '-inf' - if (@_ == 0 || (defined($_[0]) && !ref($_[0]) && - $_[0] =~ /^\s*[+-](inf(inity)?)?\s*$/)) + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) { - #carp("Using binf() as a function is deprecated;", - # " use binf() as a method instead"); + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; unshift @_, __PACKAGE__; } @@ -1085,10 +971,26 @@ sub binf { } $self->import() if $IMPORT == 0; # make require work - return if $selfref && $self->modify('binf'); - my $sign = shift; - $sign = defined $sign && $sign =~ /^\s*-/ ? "-" : "+"; + # Don't modify constant (read-only) objects. + + return $self if $selfref && $self->modify('binf'); + + return $downgrade -> binf(@_) if $downgrade; + + # Get the sign. + + my $sign = '+'; # default is to return positive infinity + if (defined($_[0]) && $_[0] =~ /^\s*([+-])(inf|$)/i) { + $sign = $1; + shift; + } + + # Get the rounding parameters, if any. + + my @r = @_; + + # If called as a class method, initialize a new object. $self = bless {}, $class unless $selfref; @@ -1101,11 +1003,13 @@ sub binf { # parameters are given, and if called as a class method initialize the new # instance with the class variables. - if (@_) { + #return $self -> round(@r); # this should work, but doesnt; fixme! + + if (@r) { croak "can't specify both accuracy and precision" - if @_ >= 2 && defined $_[0] && defined $_[1]; - $self->{_a} = $_[0]; - $self->{_p} = $_[1]; + if @r >= 2 && defined($r[0]) && defined($r[1]); + $self->{_a} = $r[0]; + $self->{_p} = $r[1]; } else { unless($selfref) { $self->{_a} = $class -> accuracy(); @@ -1119,9 +1023,12 @@ sub binf { sub bnan { # create/assign a 'NaN' - if (@_ == 0) { - #carp("Using bnan() as a function is deprecated;", - # " use bnan() as a method instead"); + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) + { + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; unshift @_, __PACKAGE__; } @@ -1137,7 +1044,18 @@ sub bnan { } $self->import() if $IMPORT == 0; # make require work - return if $selfref && $self->modify('bnan'); + + # Don't modify constant (read-only) objects. + + return $self if $selfref && $self->modify('bnan'); + + return $downgrade -> bnan(@_) if defined $downgrade; + + # Get the rounding parameters, if any. + + my @r = @_; + + # If called as a class method, initialize a new object. $self = bless {}, $class unless $selfref; @@ -1150,11 +1068,13 @@ sub bnan { # parameters are given, and if called as a class method initialize the new # instance with the class variables. - if (@_) { + #return $self -> round(@r); # this should work, but doesnt; fixme! + + if (@r) { croak "can't specify both accuracy and precision" - if @_ >= 2 && defined $_[0] && defined $_[1]; - $self->{_a} = $_[0]; - $self->{_p} = $_[1]; + if @r >= 2 && defined($r[0]) && defined($r[1]); + $self->{_a} = $r[0]; + $self->{_p} = $r[1]; } else { unless($selfref) { $self->{_a} = $class -> accuracy(); @@ -1167,6 +1087,15 @@ sub bnan { sub bpi { + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) + { + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; + unshift @_, __PACKAGE__; + } + # Called as Argument list # --------- ------------- # Math::BigFloat->bpi() ("Math::BigFloat") @@ -1188,35 +1117,12 @@ sub bpi { my $self = shift; my $selfref = ref $self; my $class = $selfref || $self; + my @r = @_; # rounding paramters - my @r; # rounding paramters - - # If bpi() is called as a function ... - # - # This cludge is necessary because we still support bpi() as a function. If - # bpi() is called with either no argument or one argument, and that one - # argument is either undefined or a scalar that looks like a number, then - # we assume bpi() is called as a function. - - if (@_ == 0 && - (defined($self) && !ref($self) && $self =~ /^\s*[+-]?\d/i) - || - !defined($self)) - { - $r[0] = $self; - $class = __PACKAGE__; - $self = $class -> bzero(@r); # initialize - } - - # ... or if bpi() is called as a method ... - - else { - @r = @_; - if ($selfref) { # bpi() called as instance method - return $self if $self -> modify('bpi'); - } else { # bpi() called as class method - $self = $class -> bzero(@r); # initialize - } + if ($selfref) { # bpi() called as an instance method + return $self if $self -> modify('bpi'); + } else { # bpi() called as a class method + $self = bless {}, $class; # initialize new instance } ($self, @r) = $self -> _find_round_parameters(@r); @@ -1291,13 +1197,19 @@ EOF if ($last_digit lt '9') { substr($digits, -1, 1) = ++$last_digit; } else { - $digits =~ s/([0-8])(9+)$/ ($1 + 1) . ("0" x CORE::length($2)) /e; + $digits =~ s{([0-8])(9+)$} + { ($1 + 1) . ("0" x CORE::length($2)) }e; } } - # Append the exponent and convert to an object. + # Convert to an object. - $pi = Math::BigFloat -> new($digits . 'e-' . ($n - 1)); + $pi = bless { + sign => '+', + _m => $LIB -> _new($digits), + _es => '-', + _e => $LIB -> _new($n - 1), + }, $class; } else { @@ -1308,20 +1220,21 @@ EOF $n += 8; $HALF = $class -> new($HALF) unless ref($HALF); - my ($an, $bn, $tn, $pn) = ($class -> bone, $HALF -> copy() -> bsqrt($n), - $HALF -> copy() -> bmul($HALF), $class -> bone); + my ($an, $bn, $tn, $pn) + = ($class -> bone, $HALF -> copy() -> bsqrt($n), + $HALF -> copy() -> bmul($HALF), $class -> bone); while ($pn < $n) { my $prev_an = $an -> copy(); - $an -> badd($bn) -> bmul($HALF, $n); - $bn -> bmul($prev_an) -> bsqrt($n); - $prev_an -> bsub($an); - $tn -> bsub($pn * $prev_an * $prev_an); - $pn -> badd($pn); + $an = $an -> badd($bn) -> bmul($HALF, $n); + $bn = $bn -> bmul($prev_an) -> bsqrt($n); + $prev_an = $prev_an -> bsub($an); + $tn = $tn -> bsub($pn * $prev_an * $prev_an); + $pn = $pn -> badd($pn); } - $an -> badd($bn); - $an -> bmul($an, $n) -> bdiv(4 * $tn, $n); + $an = $an -> badd($bn); + $an = $an -> bmul($an, $n) -> bdiv(4 * $tn, $n); - $an -> round(@r); + $an = $an -> round(@r); $pi = $an; } @@ -1335,54 +1248,95 @@ EOF $self -> {$key} = $pi -> {$key}; } + return $downgrade -> new($self -> bdstr(), @r) + if defined($downgrade) && $self->is_int(); return $self; } sub copy { - my $self = shift; - my $selfref = ref $self; - my $class = $selfref || $self; - - # If called as a class method, the object to copy is the next argument. + my ($x, $class); + if (ref($_[0])) { # $y = $x -> copy() + $x = shift; + $class = ref($x); + } else { # $y = Math::BigInt -> copy($y) + $class = shift; + $x = shift; + } - $self = shift() unless $selfref; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @_; my $copy = bless {}, $class; - $copy->{sign} = $self->{sign}; - $copy->{_es} = $self->{_es}; - $copy->{_m} = $LIB->_copy($self->{_m}); - $copy->{_e} = $LIB->_copy($self->{_e}); - $copy->{_a} = $self->{_a} if exists $self->{_a}; - $copy->{_p} = $self->{_p} if exists $self->{_p}; + $copy->{sign} = $x->{sign}; + $copy->{_es} = $x->{_es}; + $copy->{_m} = $LIB->_copy($x->{_m}); + $copy->{_e} = $LIB->_copy($x->{_e}); + $copy->{_a} = $x->{_a} if exists $x->{_a}; + $copy->{_p} = $x->{_p} if exists $x->{_p}; return $copy; } -sub as_number { +sub as_int { # return copy as a bigint representation of this Math::BigFloat number - my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - return $x if $x->modify('as_number'); + return $x -> copy() if $x -> isa("Math::BigInt"); - if (!$x->isa('Math::BigFloat')) { - # if the object can as_number(), use it - return $x->as_number() if $x->can('as_number'); - # otherwise, get us a float and then a number - $x = $x->can('as_float') ? $x->as_float() : $class->new(0+"$x"); - } + # disable upgrading and downgrading - return Math::BigInt->binf($x->sign()) if $x->is_inf(); - return Math::BigInt->bnan() if $x->is_nan(); + require Math::BigInt; + my $upg = Math::BigInt -> upgrade(); + my $dng = Math::BigInt -> downgrade(); + Math::BigInt -> upgrade(undef); + Math::BigInt -> downgrade(undef); - my $z = $LIB->_copy($x->{_m}); - if ($x->{_es} eq '-') { # < 0 - $z = $LIB->_rsft($z, $x->{_e}, 10); - } elsif (! $LIB->_is_zero($x->{_e})) { # > 0 - $z = $LIB->_lsft($z, $x->{_e}, 10); + my $y; + if ($x -> is_inf()) { + $y = Math::BigInt -> binf($x->sign()); + } elsif ($x -> is_nan()) { + $y = Math::BigInt -> bnan(); + } else { + $y = $LIB->_copy($x->{_m}); + if ($x->{_es} eq '-') { # < 0 + $y = $LIB->_rsft($y, $x->{_e}, 10); + } elsif (! $LIB->_is_zero($x->{_e})) { # > 0 + $y = $LIB->_lsft($y, $x->{_e}, 10); + } + $y = Math::BigInt->new($x->{sign} . $LIB->_str($y)); } - $z = Math::BigInt->new($x->{sign} . $LIB->_str($z)); - $z; + + # reset upgrading and downgrading + + Math::BigInt -> upgrade($upg); + Math::BigInt -> downgrade($dng); + + return $y; +} + +sub as_float { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + return $x -> copy() if $x -> isa("Math::BigFloat"); + + # disable upgrading and downgrading + + require Math::BigFloat; + my $upg = Math::BigFloat -> upgrade(); + my $dng = Math::BigFloat -> downgrade(); + Math::BigFloat -> upgrade(undef); + Math::BigFloat -> downgrade(undef); + + my $y = Math::BigFloat -> new($x); + + # reset upgrading and downgrading + + Math::BigFloat -> upgrade($upg); + Math::BigFloat -> downgrade($dng); + + return $y; } ############################################################################### @@ -1391,14 +1345,14 @@ sub as_number { sub is_zero { # return true if arg (BFLOAT or num_str) is zero - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); ($x->{sign} eq '+' && $LIB->_is_zero($x->{_m})) ? 1 : 0; } sub is_one { # return true if arg (BFLOAT or num_str) is +1 or -1 if signis given - my ($class, $x, $sign) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my (undef, $x, $sign) = ref($_[0]) ? (undef, @_) : objectify(1, @_); $sign = '+' if !defined $sign || $sign ne '-'; @@ -1409,7 +1363,7 @@ sub is_one { sub is_odd { # return true if arg (BFLOAT or num_str) is odd or false if even - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); (($x->{sign} =~ /^[+-]$/) && # NaN & +-inf aren't ($LIB->_is_zero($x->{_e})) && @@ -1418,7 +1372,7 @@ sub is_odd { sub is_even { # return true if arg (BINT or num_str) is even or false if odd - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); (($x->{sign} =~ /^[+-]$/) && # NaN & +-inf aren't ($x->{_es} eq '+') && # 123.45 isn't @@ -1427,7 +1381,7 @@ sub is_even { sub is_int { # return true if arg (BFLOAT or num_str) is an integer - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); (($x->{sign} =~ /^[+-]$/) && # NaN and +-inf aren't ($x->{_es} eq '+')) ? 1 : 0; # 1e-1 => no integer @@ -1441,19 +1395,15 @@ sub bcmp { # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort) # set up parameters - my ($class, $x, $y) = (ref($_[0]), @_); - - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); - return $upgrade->bcmp($x, $y) if defined $upgrade && - ((!$x->isa($class)) || (!$y->isa($class))); + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; # Handle all 'nan' cases. - return undef if ($x->{sign} eq $nan) || ($y->{sign} eq $nan); + return if ($x->{sign} eq $nan) || ($y->{sign} eq $nan); # Handle all '+inf' and '-inf' cases. @@ -1488,8 +1438,9 @@ sub bcmp { my $mxl = $LIB->_len($x->{_m}); my $myl = $LIB->_len($y->{_m}); - # If the mantissas have the same length, there is no point in normalizing the - # exponents by the length of the mantissas, so treat that as a special case. + # If the mantissas have the same length, there is no point in normalizing + # the exponents by the length of the mantissas, so treat that as a special + # case. if ($mxl == $myl) { @@ -1527,8 +1478,8 @@ sub bcmp { if ($x->{_es} eq '+') { - # If the exponent of x is >= 0 and the exponent of y is >= 0, there is no - # need to do anything special. + # If the exponent of x is >= 0 and the exponent of y is >= 0, there is + # no need to do anything special. if ($y->{_es} eq '+') { $ex = $LIB->_copy($x->{_e}); @@ -1577,8 +1528,8 @@ sub bcmp { return $cmp if $cmp; # Compare the mantissas, but first normalize them by padding the shorter - # mantissa with zeros (shift left) until it has the same length as the longer - # mantissa. + # mantissa with zeros (shift left) until it has the same length as the + # longer mantissa. my $mx = $x->{_m}; my $my = $y->{_m}; @@ -1600,20 +1551,17 @@ sub bacmp { # Returns one of undef, <0, =0, >0. (suitable for sort) # set up parameters - my ($class, $x, $y) = (ref($_[0]), @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); - return $upgrade->bacmp($x, $y) if defined $upgrade && - ((!$x->isa($class)) || (!$y->isa($class))); + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; # handle +-inf and NaN's if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/) { - return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); - return 0 if ($x->is_inf() && $y->is_inf()); - return 1 if ($x->is_inf() && !$y->is_inf()); + return if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); + return 0 if ($x->is_inf() && $y->is_inf()); + return 1 if ($x->is_inf() && !$y->is_inf()); return -1; } @@ -1658,20 +1606,35 @@ sub bacmp { sub bneg { # (BINT or num_str) return BINT # negate number or make a negated number from string - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my (undef, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); return $x if $x->modify('bneg'); - # for +0 do not negate (to have always normalized +0). Does nothing for 'NaN' - $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $LIB->_is_zero($x->{_m})); - $x; + return $x -> bnan(@r) if $x -> is_nan(); + + # For +0 do not negate (to have always normalized +0). + $x->{sign} =~ tr/+-/-+/ + unless $x->{sign} eq '+' && $LIB->_is_zero($x->{_m}); + + return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade) + && ($x -> is_int() || $x -> is_inf() || $x -> is_nan()); + return $x -> round(@r); } sub bnorm { + # bnorm() can't support rounding, because bround() and bfround() call + # bnorm(), which would recurse indefinitely. + # adjust m and e so that m is smallest possible - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my (undef, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); - return $x if $x->{sign} !~ /^[+-]$/; # inf, nan etc + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # inf, nan etc + if ($x->{sign} !~ /^[+-]$/) { + return $downgrade -> new($x) if defined $downgrade; + return $x; + } my $zeros = $LIB->_zeros($x->{_m}); # correct for trailing zeros if ($zeros != 0) { @@ -1690,12 +1653,17 @@ sub bnorm { } } else { # $x can only be 0Ey if there are no trailing zeros ('0' has 0 trailing - # zeros). So, for something like 0Ey, set y to 1, and -0 => +0 - $x->{sign} = '+', $x->{_es} = '+', $x->{_e} = $LIB->_one() - if $LIB->_is_zero($x->{_m}); + # zeros). So, for something like 0Ey, set y to 0, and -0 => +0 + if ($LIB->_is_zero($x->{_m})) { + $x->{sign} = '+'; + $x->{_es} = '+'; + $x->{_e} = $LIB->_zero(); + } } - $x; + return $downgrade -> new($x) + if defined($downgrade) && $x->is_int(); + return $x; } sub binc { @@ -1704,19 +1672,28 @@ sub binc { return $x if $x->modify('binc'); + # Inf and NaN + + return $x -> bnan(@r) if $x -> is_nan(); + return $x -> binf($x->{sign}, @r) if $x -> is_inf(); + + # Non-integer + if ($x->{_es} eq '-') { - return $x->badd($class->bone(), @r); # digits after dot + return $x->badd($class->bone(), @r); } - if (!$LIB->_is_zero($x->{_e})) # _e == 0 for NaN, inf, -inf - { - # 1e2 => 100, so after the shift below _m has a '0' as last digit + # If the exponent is non-zero, convert the internal representation, so that, + # e.g., 12e+3 becomes 12000e+0 and we can easily increment the mantissa. + + if (!$LIB->_is_zero($x->{_e})) { $x->{_m} = $LIB->_lsft($x->{_m}, $x->{_e}, 10); # 1e2 => 100 - $x->{_e} = $LIB->_zero(); # normalize + $x->{_e} = $LIB->_zero(); # normalize $x->{_es} = '+'; # we know that the last digit of $x will be '1' or '9', depending on the # sign } + # now $x->{_e} == 0 if ($x->{sign} eq '+') { $x->{_m} = $LIB->_inc($x->{_m}); @@ -1726,8 +1703,10 @@ sub binc { $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # -1 +1 => -0 => +0 return $x->bnorm()->bround(@r); } - # inf, nan handling etc - $x->badd($class->bone(), @r); # badd() does round + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && $x -> is_int(); + return $x; } sub bdec { @@ -1736,143 +1715,167 @@ sub bdec { return $x if $x->modify('bdec'); + # Inf and NaN + + return $x -> bnan(@r) if $x -> is_nan(); + return $x -> binf($x->{sign}, @r) if $x -> is_inf(); + + # Non-integer + if ($x->{_es} eq '-') { - return $x->badd($class->bone('-'), @r); # digits after dot + return $x->badd($class->bone('-'), @r); } + # If the exponent is non-zero, convert the internal representation, so that, + # e.g., 12e+3 becomes 12000e+0 and we can easily increment the mantissa. + if (!$LIB->_is_zero($x->{_e})) { $x->{_m} = $LIB->_lsft($x->{_m}, $x->{_e}, 10); # 1e2 => 100 - $x->{_e} = $LIB->_zero(); # normalize + $x->{_e} = $LIB->_zero(); # normalize $x->{_es} = '+'; } + # now $x->{_e} == 0 my $zero = $x->is_zero(); - # <= 0 - if (($x->{sign} eq '-') || $zero) { + if (($x->{sign} eq '-') || $zero) { # x <= 0 $x->{_m} = $LIB->_inc($x->{_m}); $x->{sign} = '-' if $zero; # 0 => 1 => -1 $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # -1 +1 => -0 => +0 return $x->bnorm()->round(@r); } - # > 0 - elsif ($x->{sign} eq '+') { + elsif ($x->{sign} eq '+') { # x > 0 $x->{_m} = $LIB->_dec($x->{_m}); return $x->bnorm()->round(@r); } - # inf, nan handling etc - $x->badd($class->bone('-'), @r); # does round + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && $x -> is_int(); + return $x -> round(@r); } sub badd { - # add second arg (BFLOAT or string) to first (BFLOAT) (modifies first) - # return result as BFLOAT - # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x->modify('badd'); # inf and NaN handling - if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/)) { - # NaN first - return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); - # inf handling - if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/)) { - # +inf++inf or -inf+-inf => same, rest is NaN - return $x if $x->{sign} eq $y->{sign}; - return $x->bnan(); + if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/) { + + # $x is NaN and/or $y is NaN + if ($x->{sign} eq $nan || $y->{sign} eq $nan) { + $x = $x->bnan(); } - # +-inf + something => +inf; something +-inf => +-inf - $x->{sign} = $y->{sign}, return $x if $y->{sign} =~ /^[+-]inf$/; - return $x; + + # $x is Inf and $y is Inf + elsif ($x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/) { + # +Inf + +Inf or -Inf + -Inf => same, rest is NaN + $x = $x->bnan() if $x->{sign} ne $y->{sign}; + } + + # +-inf + something => +-inf; something +-inf => +-inf + elsif ($y->{sign} =~ /^[+-]inf$/) { + $x->{sign} = $y->{sign}; + } + + return $downgrade -> new($x -> bdstr(), @r) if defined $downgrade; + return $x -> round(@r); } - return $upgrade->badd($x, $y, @r) if defined $upgrade && - ((!$x->isa($class)) || (!$y->isa($class))); + return $upgrade->badd($x, $y, @r) if defined $upgrade; $r[3] = $y; # no push! - # speed: no add for 0+y or x+0 - return $x->bround(@r) if $y->is_zero(); # x+0 - if ($x->is_zero()) # 0+y - { + # for speed: no add for $x + 0 + if ($y->is_zero()) { + $x = $x->round(@r); + } + + # for speed: no add for 0 + $y + elsif ($x->is_zero()) { # make copy, clobbering up x (modify in place!) $x->{_e} = $LIB->_copy($y->{_e}); $x->{_es} = $y->{_es}; $x->{_m} = $LIB->_copy($y->{_m}); $x->{sign} = $y->{sign} || $nan; - return $x->round(@r); + $x = $x->round(@r); } - # take lower of the two e's and adapt m1 to it to match m2 - my $e = $y->{_e}; - $e = $LIB->_zero() if !defined $e; # if no BFLOAT? - $e = $LIB->_copy($e); # make copy (didn't do it yet) + # both $x and $y are non-zero + else { - my $es; + # take lower of the two e's and adapt m1 to it to match m2 + my $e = $y->{_e}; + $e = $LIB->_zero() if !defined $e; # if no BFLOAT? + $e = $LIB->_copy($e); # make copy (didn't do it yet) - ($e, $es) = _e_sub($e, $x->{_e}, $y->{_es} || '+', $x->{_es}); + my $es; - my $add = $LIB->_copy($y->{_m}); + ($e, $es) = $LIB -> _ssub($e, $y->{_es} || '+', $x->{_e}, $x->{_es}); - if ($es eq '-') # < 0 - { - $x->{_m} = $LIB->_lsft($x->{_m}, $e, 10); - ($x->{_e}, $x->{_es}) = _e_add($x->{_e}, $e, $x->{_es}, $es); - } elsif (!$LIB->_is_zero($e)) # > 0 - { - $add = $LIB->_lsft($add, $e, 10); - } - # else: both e are the same, so just leave them + my $add = $LIB->_copy($y->{_m}); - if ($x->{sign} eq $y->{sign}) { - # add - $x->{_m} = $LIB->_add($x->{_m}, $add); - } else { - ($x->{_m}, $x->{sign}) = - _e_add($x->{_m}, $add, $x->{sign}, $y->{sign}); + if ($es eq '-') { # < 0 + $x->{_m} = $LIB->_lsft($x->{_m}, $e, 10); + ($x->{_e}, $x->{_es}) = $LIB -> _sadd($x->{_e}, $x->{_es}, $e, $es); + } elsif (!$LIB->_is_zero($e)) { # > 0 + $add = $LIB->_lsft($add, $e, 10); + } + + # else: both e are the same, so just leave them + + if ($x->{sign} eq $y->{sign}) { + $x->{_m} = $LIB->_add($x->{_m}, $add); + } else { + ($x->{_m}, $x->{sign}) = + $LIB -> _sadd($x->{_m}, $x->{sign}, $add, $y->{sign}); + } + + # delete trailing zeros, then round + $x = $x->bnorm()->round(@r); } - # delete trailing zeros, then round - $x->bnorm()->round(@r); + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && $x -> is_int(); + return $x; # rounding already done above } sub bsub { - # (BINT or num_str, BINT or num_str) return BINT - # subtract second arg from first, modify first - # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x -> modify('bsub'); - return $upgrade -> new($x) -> bsub($upgrade -> new($y), @r) - if defined $upgrade && (!$x -> isa($class) || !$y -> isa($class)); - - return $x -> round(@r) if $y -> is_zero(); + if ($y -> is_zero()) { + $x = $x -> round(@r); + } else { - # To correctly handle the lone special case $x -> bsub($x), we note the - # sign of $x, then flip the sign from $y, and if the sign of $x did change, - # too, then we caught the special case: + # To correctly handle the special case $x -> bsub($x), we note the sign + # of $x, then flip the sign of $y, and if the sign of $x changed too, + # then we know that $x and $y are the same object. - my $xsign = $x -> {sign}; - $y -> {sign} =~ tr/+-/-+/; # does nothing for NaN - if ($xsign ne $x -> {sign}) { - # special case of $x -> bsub($x) results in 0 - return $x -> bzero(@r) if $xsign =~ /^[+-]$/; - return $x -> bnan(); # NaN, -inf, +inf + my $xsign = $x -> {sign}; + $y -> {sign} =~ tr/+-/-+/; # does nothing for NaN + if ($xsign ne $x -> {sign}) { + # special case of $x -> bsub($x) results in 0 + if ($xsign =~ /^[+-]$/) { + $x = $x -> bzero(@r); + } else { + $x = $x -> bnan(); # NaN, -inf, +inf + } + return $downgrade -> new($x -> bdstr(), @r) if defined $downgrade; + return $x -> round(@r); + } + $x = $x -> badd($y, @r); # badd does not leave internal zeros + $y -> {sign} =~ tr/+-/-+/; # reset $y (does nothing for NaN) } - $x -> badd($y, @r); # badd does not leave internal zeros - $y -> {sign} =~ tr/+-/-+/; # refix $y (does nothing for NaN) + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && ($x->is_int() || $x->is_inf() || $x->is_nan()); $x; # already rounded by badd() or no rounding } @@ -1880,70 +1883,73 @@ sub bmul { # multiply two numbers # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x->modify('bmul'); - return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); + return $x->bnan(@r) if ($x->{sign} eq $nan) || ($y->{sign} eq $nan); # inf handling if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/)) { - return $x->bnan() if $x->is_zero() || $y->is_zero(); + return $x->bnan(@r) if $x->is_zero() || $y->is_zero(); # result will always be +-inf: # +inf * +/+inf => +inf, -inf * -/-inf => +inf # +inf * -/-inf => -inf, -inf * +/+inf => -inf - return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/); - return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/); - return $x->binf('-'); + return $x->binf(@r) if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/); + return $x->binf(@r) if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/); + return $x->binf('-', @r); } - return $upgrade->bmul($x, $y, @r) if defined $upgrade && - ((!$x->isa($class)) || (!$y->isa($class))); + return $upgrade->bmul($x, $y, @r) if defined $upgrade; # aEb * cEd = (a*c)E(b+d) $x->{_m} = $LIB->_mul($x->{_m}, $y->{_m}); - ($x->{_e}, $x->{_es}) = _e_add($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es}); + ($x->{_e}, $x->{_es}) + = $LIB -> _sadd($x->{_e}, $x->{_es}, $y->{_e}, $y->{_es}); $r[3] = $y; # no push! # adjust sign: $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+'; - $x->bnorm->round(@r); + $x = $x->bnorm->round(@r); + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; } sub bmuladd { # multiply two numbers and add the third to the result # set up parameters - my ($class, $x, $y, $z, @r) = objectify(3, @_); + my ($class, $x, $y, $z, @r) + = ref($_[0]) && ref($_[0]) eq ref($_[1]) && ref($_[1]) eq ref($_[2]) + ? (ref($_[0]), @_) + : objectify(3, @_); return $x if $x->modify('bmuladd'); - return $x->bnan() if (($x->{sign} eq $nan) || - ($y->{sign} eq $nan) || - ($z->{sign} eq $nan)); + return $x->bnan(@r) if (($x->{sign} eq $nan) || + ($y->{sign} eq $nan) || + ($z->{sign} eq $nan)); # inf handling if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/)) { - return $x->bnan() if $x->is_zero() || $y->is_zero(); + return $x->bnan(@r) if $x->is_zero() || $y->is_zero(); # result will always be +-inf: # +inf * +/+inf => +inf, -inf * -/-inf => +inf # +inf * -/-inf => -inf, -inf * +/+inf => -inf - return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/); - return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/); - return $x->binf('-'); + return $x->binf(@r) if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/); + return $x->binf(@r) if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/); + return $x->binf('-', @r); } - return $upgrade->bmul($x, $y, @r) if defined $upgrade && - ((!$x->isa($class)) || (!$y->isa($class))); - # aEb * cEd = (a*c)E(b+d) $x->{_m} = $LIB->_mul($x->{_m}, $y->{_m}); - ($x->{_e}, $x->{_es}) = _e_add($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es}); + ($x->{_e}, $x->{_es}) + = $LIB -> _sadd($x->{_e}, $x->{_es}, $y->{_e}, $y->{_es}); $r[3] = $y; # no push! @@ -1951,7 +1957,11 @@ sub bmuladd { $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+'; # z=inf handling (z=NaN handled above) - $x->{sign} = $z->{sign}, return $x if $z->{sign} =~ /^[+-]inf$/; + if ($z->{sign} =~ /^[+-]inf$/) { + $x->{sign} = $z->{sign}; + return $downgrade -> new($x -> bdstr(), @r) if defined $downgrade; + return $x -> round(@r); + } # take lower of the two e's and adapt m1 to it to match m2 my $e = $z->{_e}; @@ -1960,14 +1970,14 @@ sub bmuladd { my $es; - ($e, $es) = _e_sub($e, $x->{_e}, $z->{_es} || '+', $x->{_es}); + ($e, $es) = $LIB -> _ssub($e, $z->{_es} || '+', $x->{_e}, $x->{_es}); my $add = $LIB->_copy($z->{_m}); if ($es eq '-') # < 0 { $x->{_m} = $LIB->_lsft($x->{_m}, $e, 10); - ($x->{_e}, $x->{_es}) = _e_add($x->{_e}, $e, $x->{_es}, $es); + ($x->{_e}, $x->{_es}) = $LIB -> _sadd($x->{_e}, $x->{_es}, $e, $es); } elsif (!$LIB->_is_zero($e)) # > 0 { $add = $LIB->_lsft($add, $e, 10); @@ -1979,11 +1989,15 @@ sub bmuladd { $x->{_m} = $LIB->_add($x->{_m}, $add); } else { ($x->{_m}, $x->{sign}) = - _e_add($x->{_m}, $add, $x->{sign}, $z->{sign}); + $LIB -> _sadd($x->{_m}, $x->{sign}, $add, $z->{sign}); } # delete trailing zeros, then round - $x->bnorm()->round(@r); + $x = $x->bnorm()->round(@r); + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; } sub bdiv { @@ -1991,10 +2005,10 @@ sub bdiv { # (BFLOAT, BFLOAT) (quo, rem) or BFLOAT (only quo) # set up parameters - my ($class, $x, $y, $a, $p, $r) = (ref($_[0]), @_); + my ($class, $x, $y, @r) = (ref($_[0]), @_); # objectify is costly, so avoid it if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, $a, $p, $r) = objectify(2, @_); + ($class, $x, $y, @r) = objectify(2, @_); } return $x if $x->modify('bdiv'); @@ -2005,7 +2019,8 @@ sub bdiv { # Math::BigInt -> bdiv(). if ($x -> is_nan() || $y -> is_nan()) { - return $wantarray ? ($x -> bnan(), $class -> bnan()) : $x -> bnan(); + return $wantarray ? ($x -> bnan(@r), $class -> bnan(@r)) + : $x -> bnan(@r); } # Divide by zero and modulo zero. This is handled the same way as in @@ -2015,12 +2030,14 @@ sub bdiv { if ($y -> is_zero()) { my ($quo, $rem); if ($wantarray) { - $rem = $x -> copy(); + $rem = $x -> copy() -> round(@r); + $rem = $downgrade -> new($rem, @r) + if defined($downgrade) && $rem -> is_int(); } if ($x -> is_zero()) { - $quo = $x -> bnan(); + $quo = $x -> bnan(@r); } else { - $quo = $x -> binf($x -> {sign}); + $quo = $x -> binf($x -> {sign}, @r); } return $wantarray ? ($quo, $rem) : $quo; } @@ -2031,12 +2048,12 @@ sub bdiv { if ($x -> is_inf()) { my ($quo, $rem); - $rem = $class -> bnan() if $wantarray; + $rem = $class -> bnan(@r) if $wantarray; if ($y -> is_inf()) { - $quo = $x -> bnan(); + $quo = $x -> bnan(@r); } else { my $sign = $x -> bcmp(0) == $y -> bcmp(0) ? '+' : '-'; - $quo = $x -> binf($sign); + $quo = $x -> binf($sign, @r); } return $wantarray ? ($quo, $rem) : $quo; } @@ -2051,19 +2068,21 @@ sub bdiv { my ($quo, $rem); if ($wantarray) { if ($x -> is_zero() || $x -> bcmp(0) == $y -> bcmp(0)) { - $rem = $x -> copy(); - $quo = $x -> bzero(); + $rem = $x -> copy() -> round(@r); + $rem = $downgrade -> new($rem, @r) + if defined($downgrade) && $rem -> is_int(); + $quo = $x -> bzero(@r); } else { - $rem = $class -> binf($y -> {sign}); - $quo = $x -> bone('-'); + $rem = $class -> binf($y -> {sign}, @r); + $quo = $x -> bone('-', @r); } return ($quo, $rem); } else { if ($y -> is_inf()) { if ($x -> is_nan() || $x -> is_inf()) { - return $x -> bnan(); + return $x -> bnan(@r); } else { - return $x -> bzero(); + return $x -> bzero(@r); } } } @@ -2073,24 +2092,37 @@ sub bdiv { # the denominator (divisor) is non-zero. # x == 0? - return wantarray ? ($x, $class->bzero()) : $x if $x->is_zero(); + if ($x->is_zero()) { + my ($quo, $rem); + $quo = $x->round(@r); + $quo = $downgrade -> new($quo, @r) + if defined($downgrade) && $quo -> is_int(); + if ($wantarray) { + $rem = $class -> bzero(@r); + return $quo, $rem; + } + return $quo; + } + + # Division might return a value that we can not represent exactly, so + # upgrade, if upgrading is enabled. - # upgrade ? - return $upgrade->bdiv($upgrade->new($x), $y, $a, $p, $r) if defined $upgrade; + return $upgrade -> bdiv($x, $y, @r) + if defined($upgrade) && !wantarray && !$LIB -> _is_one($y -> {_m}); # we need to limit the accuracy to protect against overflow my $fallback = 0; my (@params, $scale); - ($x, @params) = $x->_find_round_parameters($a, $p, $r, $y); + ($x, @params) = $x->_find_round_parameters($r[0], $r[1], $r[2], $y); - return $x if $x->is_nan(); # error in _find_round_parameters? + return $x -> round(@r) if $x->is_nan(); # error in _find_round_parameters? # no rounding at all, so must use fallback if (scalar @params == 0) { # simulate old behaviour $params[0] = $class->div_scale(); # and round to it as accuracy $scale = $params[0]+4; # at least four more for proper round - $params[2] = $r; # round mode by caller or undef + $params[2] = $r[2]; # round mode by caller or undef $fallback = 1; # to clear a/p afterwards } else { # the 4 below is empirical, and there might be cases where it is not @@ -2103,7 +2135,8 @@ sub bdiv { $y = $class->new($y) unless $y->isa('Math::BigFloat'); - my $lx = $LIB -> _len($x->{_m}); my $ly = $LIB -> _len($y->{_m}); + my $lx = $LIB -> _len($x->{_m}); + my $ly = $LIB -> _len($y->{_m}); $scale = $lx if $lx > $scale; $scale = $ly if $ly > $scale; my $diff = $ly - $lx; @@ -2119,13 +2152,14 @@ sub bdiv { if ($xsign ne $x->{sign}) { # special case of $x /= $x results in 1 - $x->bone(); # "fixes" also sign of $y, since $x is $y + $x = $x->bone(); # "fixes" also sign of $y, since $x is $y } else { # correct $y's sign again $y->{sign} =~ tr/+-/-+/; # continue with normal div code: - # make copy of $x in case of list context for later remainder calculation + # make copy of $x in case of list context for later remainder + # calculation if (wantarray && $y_not_one) { $rem = $x->copy(); } @@ -2134,7 +2168,8 @@ sub bdiv { # check for / +-1 (+/- 1E0) if ($y_not_one) { - # promote BigInts and it's subclasses (except when already a Math::BigFloat) + # promote Math::BigInt and its subclasses (except when already a + # Math::BigFloat) $y = $class->new($y) unless $y->isa('Math::BigFloat'); # calculate the result to $scale digits and then round it @@ -2143,70 +2178,77 @@ sub bdiv { $x->{_m} = $LIB->_div($x->{_m}, $y->{_m}); # a/c # correct exponent of $x - ($x->{_e}, $x->{_es}) = _e_sub($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es}); + ($x->{_e}, $x->{_es}) + = $LIB -> _ssub($x->{_e}, $x->{_es}, $y->{_e}, $y->{_es}); # correct for 10**scale - ($x->{_e}, $x->{_es}) = _e_sub($x->{_e}, $LIB->_new($scale), $x->{_es}, '+'); - $x->bnorm(); # remove trailing 0's + ($x->{_e}, $x->{_es}) + = $LIB -> _ssub($x->{_e}, $x->{_es}, $LIB->_new($scale), '+'); + $x = $x->bnorm(); # remove trailing 0's } } # end else $x != $y # shortcut to not run through _find_round_parameters again if (defined $params[0]) { delete $x->{_a}; # clear before round - $x->bround($params[0], $params[2]); # then round accordingly + $x = $x->bround($params[0], $params[2]); # then round accordingly } else { delete $x->{_p}; # clear before round - $x->bfround($params[1], $params[2]); # then round accordingly + $x = $x->bfround($params[1], $params[2]); # then round accordingly } if ($fallback) { # clear a/p after round, since user did not request it - delete $x->{_a}; delete $x->{_p}; + delete $x->{_a}; + delete $x->{_p}; } if (wantarray) { if ($y_not_one) { - $x -> bfloor(); - $rem->bmod($y, @params); # copy already done + $x = $x -> bfloor(); + $rem = $rem->bmod($y, @params); # copy already done } if ($fallback) { # clear a/p after round, since user did not request it - delete $rem->{_a}; delete $rem->{_p}; + delete $rem->{_a}; + delete $rem->{_p}; } + $x = $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && $x -> is_int(); + $rem = $downgrade -> new($rem -> bdstr(), @r) + if defined($downgrade) && $rem -> is_int(); return ($x, $rem); } - $x; + + $x = $downgrade -> new($x, @r) + if defined($downgrade) && $x -> is_int(); + $x; # rounding already done above } sub bmod { # (dividend: BFLOAT or num_str, divisor: BFLOAT or num_str) return remainder # set up parameters - my ($class, $x, $y, $a, $p, $r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, $a, $p, $r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x->modify('bmod'); # At least one argument is NaN. This is handled the same way as in # Math::BigInt -> bmod(). - if ($x -> is_nan() || $y -> is_nan()) { - return $x -> bnan(); - } + return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); # Modulo zero. This is handled the same way as in Math::BigInt -> bmod(). if ($y -> is_zero()) { - return $x; + return $x -> round(@r); } # Numerator (dividend) is +/-inf. This is handled the same way as in # Math::BigInt -> bmod(). if ($x -> is_inf()) { - return $x -> bnan(); + return $x -> bnan(@r); } # Denominator (divisor) is +/-inf. This is handled the same way as in @@ -2214,20 +2256,20 @@ sub bmod { if ($y -> is_inf()) { if ($x -> is_zero() || $x -> bcmp(0) == $y -> bcmp(0)) { - return $x; + return $x -> round(@r); } else { - return $x -> binf($y -> sign()); + return $x -> binf($y -> sign(), @r); } } - return $x->bzero() if $x->is_zero() + return $x->bzero(@r) if $x->is_zero() || ($x->is_int() && # check that $y == +1 or $y == -1: ($LIB->_is_zero($y->{_e}) && $LIB->_is_one($y->{_m}))); my $cmp = $x->bacmp($y); # equal or $x < $y? if ($cmp == 0) { # $x == $y => result 0 - return $x -> bzero($a, $p); + return $x -> bzero(@r); } # only $y of the operands negative? @@ -2235,7 +2277,7 @@ sub bmod { $x->{sign} = $y->{sign}; # calc sign first if ($cmp < 0 && $neg == 0) { # $x < $y => result $x - return $x -> round($a, $p, $r); + return $x -> round(@r); } my $ym = $LIB->_copy($y->{_m}); @@ -2250,7 +2292,8 @@ sub bmod { { # 123 % 2.5 => 1230 % 25 => 5 => 0.5 $shifty = $LIB->_num($y->{_e}); # no more digits after dot - $x->{_m} = $LIB->_lsft($x->{_m}, $y->{_e}, 10); # 123 => 1230, $y->{_m} is already 25 + # 123 => 1230, $y->{_m} is already 25 + $x->{_m} = $LIB->_lsft($x->{_m}, $y->{_e}, 10); } # $ym is now mantissa of $y based on exponent 0 @@ -2276,48 +2319,60 @@ sub bmod { $x->{_m} = $LIB->_mod($x->{_m}, $ym); $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # fix sign for -0 - $x->bnorm(); + $x = $x->bnorm(); - if ($neg != 0 && ! $x -> is_zero()) # one of them negative => correct in place - { + # if one of them negative => correct in place + if ($neg != 0 && ! $x -> is_zero()) { my $r = $y - $x; $x->{_m} = $r->{_m}; $x->{_e} = $r->{_e}; $x->{_es} = $r->{_es}; $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # fix sign for -0 - $x->bnorm(); + $x = $x->bnorm(); } - $x->round($a, $p, $r, $y); # round and return + $x = $x->round($r[0], $r[1], $r[2], $y); + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; } sub bmodpow { # takes a very large number to a very large exponent in a given very # large modulus, quickly, thanks to binary exponentiation. Supports # negative exponents. - my ($class, $num, $exp, $mod) = objectify(3, @_); + my ($class, $num, $exp, $mod, @r) + = ref($_[0]) && ref($_[0]) eq ref($_[1]) && ref($_[1]) eq ref($_[2]) + ? (ref($_[0]), @_) + : objectify(3, @_); return $num if $num->modify('bmodpow'); + return $num -> bnan(@r) + if $mod->is_nan() || $exp->is_nan() || $mod->is_nan(); + # check modulus for valid values - return $num->bnan() if ($mod->{sign} ne '+' # NaN, -, -inf, +inf - || $mod->is_zero()); + return $num->bnan(@r) if $mod->{sign} ne '+' || $mod->is_zero(); # check exponent for valid values if ($exp->{sign} =~ /\w/) { # i.e., if it's NaN, +inf, or -inf... - return $num->bnan(); + return $num->bnan(@r); } - $num->bmodinv ($mod) if ($exp->{sign} eq '-'); + $num = $num->bmodinv($mod, @r) if $exp->{sign} eq '-'; # check num for valid values (also NaN if there was no inverse but $exp < 0) - return $num->bnan() if $num->{sign} !~ /^[+-]$/; + return $num->bnan(@r) if $num->{sign} !~ /^[+-]$/; # $mod is positive, sign on $exp is ignored, result also positive # XXX TODO: speed it up when all three numbers are integers - $num->bpow($exp)->bmod($mod); + $num = $num->bpow($exp)->bmod($mod); + + return $downgrade -> new($num -> bdstr(), @r) if defined($downgrade) + && ($num->is_int() || $num->is_inf() || $num->is_nan()); + return $num -> round(@r); } sub bpow { @@ -2332,71 +2387,84 @@ sub bpow { ($class, $x, $y, $a, $p, $r) = objectify(2, @_); } - return $x if $x->modify('bpow'); + return $x if $x -> modify('bpow'); # $x and/or $y is a NaN - return $x->bnan() if $x->is_nan() || $y->is_nan(); + return $x -> bnan() if $x -> is_nan() || $y -> is_nan(); # $x and/or $y is a +/-Inf - if ($x->is_inf("-")) { - return $x->bzero() if $y->is_negative(); - return $x->bnan() if $y->is_zero(); - return $x if $y->is_odd(); - return $x->bneg(); - } elsif ($x->is_inf("+")) { - return $x->bzero() if $y->is_negative(); - return $x->bnan() if $y->is_zero(); + if ($x -> is_inf("-")) { + return $x -> bzero() if $y -> is_negative(); + return $x -> bnan() if $y -> is_zero(); + return $x if $y -> is_odd(); + return $x -> bneg(); + } elsif ($x -> is_inf("+")) { + return $x -> bzero() if $y -> is_negative(); + return $x -> bnan() if $y -> is_zero(); + return $x; + } elsif ($y -> is_inf("-")) { + return $x -> bnan() if $x -> is_one("-"); + return $x -> binf("+") if $x > -1 && $x < 1; + return $x -> bone() if $x -> is_one("+"); + return $x -> bzero(); + } elsif ($y -> is_inf("+")) { + return $x -> bnan() if $x -> is_one("-"); + return $x -> bzero() if $x > -1 && $x < 1; + return $x -> bone() if $x -> is_one("+"); + return $x -> binf("+"); + } + + if ($x -> is_zero()) { + return $x -> bone() if $y -> is_zero(); + return $x -> binf() if $y -> is_negative(); return $x; - } elsif ($y->is_inf("-")) { - return $x->bnan() if $x -> is_one("-"); - return $x->binf("+") if $x > -1 && $x < 1; - return $x->bone() if $x -> is_one("+"); - return $x->bzero(); - } elsif ($y->is_inf("+")) { - return $x->bnan() if $x -> is_one("-"); - return $x->bzero() if $x > -1 && $x < 1; - return $x->bone() if $x -> is_one("+"); - return $x->binf("+"); } - # we don't support complex numbers, so return NaN - return $x->bnan() if $x->is_negative() && !$y->is_int(); - - # cache the result of is_zero - my $y_is_zero = $y->is_zero(); - return $x->bone() if $y_is_zero; - return $x if $x->is_one() || $y->is_one(); + # We don't support complex numbers, so upgrade or return NaN. - my $x_is_zero = $x->is_zero(); - return $x->_pow($y, $a, $p, $r) if !$x_is_zero && !$y->is_int(); - - my $y1 = $y->as_number()->{value}; # make MBI part + if ($x -> is_negative() && !$y -> is_int()) { + return $upgrade -> bpow($x, $y, $a, $p, $r) if defined $upgrade; + return $x -> bnan(); + } - if ($x->is_one("-")) { - # if $x == -1 and odd/even y => +1/-1 because +-1 ^ (+-1) => +-1 - return $LIB->_is_odd($y1) ? $x : $x->babs(1); + if ($x -> is_one("+") || $y -> is_one()) { + return $x; } - if ($x_is_zero) { - return $x if $y->{sign} eq '+'; # 0**y => 0 (if not y <= 0) - # 0 ** -y => 1 / (0 ** y) => 1 / 0! (1 / 0 => +inf) - return $x->binf(); + + if ($x -> is_one("-")) { + return $x if $y -> is_odd(); + return $x -> bneg(); } + return $x -> _pow($y, $a, $p, $r) if !$y -> is_int(); + + my $y1 = $y -> as_int()->{value}; # make MBI part + my $new_sign = '+'; - $new_sign = $LIB->_is_odd($y1) ? '-' : '+' if $x->{sign} ne '+'; + $new_sign = $LIB -> _is_odd($y1) ? '-' : '+' if $x->{sign} ne '+'; # calculate $x->{_m} ** $y and $x->{_e} * $y separately (faster) - $x->{_m} = $LIB->_pow($x->{_m}, $y1); - $x->{_e} = $LIB->_mul ($x->{_e}, $y1); + $x->{_m} = $LIB -> _pow($x->{_m}, $y1); + $x->{_e} = $LIB -> _mul($x->{_e}, $y1); $x->{sign} = $new_sign; - $x->bnorm(); + $x = $x -> bnorm(); + + # x ** (-y) = 1 / (x ** y) + if ($y->{sign} eq '-') { # modify $x in place! - my $z = $x->copy(); $x->bone(); - return scalar $x->bdiv($z, $a, $p, $r); # round in one go (might ignore y's A!) + my $z = $x -> copy(); + $x = $x -> bone(); + # round in one go (might ignore y's A!) + return scalar $x -> bdiv($z, $a, $p, $r); } - $x->round($a, $p, $r, $y); + + $x = $x -> round($a, $p, $r, $y); + + return $downgrade -> new($x) + if defined($downgrade) && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; } sub blog { @@ -2404,29 +2472,32 @@ sub blog { # value is used as the base, otherwise the base is assumed to be Euler's # constant. - my ($class, $x, $base, $a, $p, $r); + my ($class, $x, $base, @r); - # Don't objectify the base, since an undefined base, as in $x->blog() or - # $x->blog(undef) signals that the base is Euler's number. + # Only objectify the base if it is defined, since an undefined base, as in + # $x->blog() or $x->blog(undef) signals that the base is Euler's number. if (!ref($_[0]) && $_[0] =~ /^[A-Za-z]|::/) { # E.g., Math::BigFloat->blog(256, 2) - ($class, $x, $base, $a, $p, $r) = + ($class, $x, $base, @r) = defined $_[2] ? objectify(2, @_) : objectify(1, @_); } else { # E.g., Math::BigFloat::blog(256, 2) or $x->blog(2) - ($class, $x, $base, $a, $p, $r) = + ($class, $x, $base, @r) = defined $_[1] ? objectify(2, @_) : objectify(1, @_); } return $x if $x->modify('blog'); - return $x -> bnan() if $x -> is_nan(); + return $x -> bnan(@r) if $x -> is_nan(); + + return $upgrade -> blog($x, $base, @r) + if defined($upgrade) && $x -> is_neg(); # we need to limit the accuracy to protect against overflow my $fallback = 0; my ($scale, @params); - ($x, @params) = $x->_find_round_parameters($a, $p, $r); + ($x, @params) = $x->_find_round_parameters(@r); # no rounding at all, so must use fallback if (scalar @params == 0) { @@ -2434,7 +2505,7 @@ sub blog { $params[0] = $class->div_scale(); # and round to it as accuracy $params[1] = undef; # P = undef $scale = $params[0]+4; # at least four more for proper round - $params[2] = $r; # round mode by caller or undef + $params[2] = $r[2]; # round mode by caller or undef $fallback = 1; # to clear a/p afterwards } else { # the 4 below is empirical, and there might be cases where it is not @@ -2444,28 +2515,29 @@ sub blog { my $done = 0; if (defined $base) { - $base = $class -> new($base) unless ref $base; + $base = $class -> new($base) + unless defined(blessed($base)) && $base -> isa($class); if ($base -> is_nan() || $base -> is_one()) { - $x -> bnan(); + $x = $x -> bnan(); $done = 1; } elsif ($base -> is_inf() || $base -> is_zero()) { if ($x -> is_inf() || $x -> is_zero()) { - $x -> bnan(); + $x = $x -> bnan(); } else { - $x -> bzero(@params); + $x = $x -> bzero(@params); } $done = 1; } elsif ($base -> is_negative()) { # -inf < base < 0 if ($x -> is_one()) { # x = 1 - $x -> bzero(@params); + $x = $x -> bzero(@params); } elsif ($x == $base) { - $x -> bone('+', @params); # x = base + $x = $x -> bone('+', @params); # x = base } else { - $x -> bnan(); # otherwise + $x = $x -> bnan(); # otherwise } $done = 1; } elsif ($x == $base) { - $x -> bone('+', @params); # 0 < base && 0 < x < inf + $x = $x -> bone('+', @params); # 0 < base && 0 < x < inf $done = 1; } } @@ -2475,17 +2547,17 @@ sub blog { unless ($done) { if ($x -> is_inf()) { # x = +/-inf my $sign = defined $base && $base < 1 ? '-' : '+'; - $x -> binf($sign); + $x = $x -> binf($sign); $done = 1; } elsif ($x -> is_neg()) { # -inf < x < 0 - $x -> bnan(); + $x = $x -> bnan(); $done = 1; } elsif ($x -> is_one()) { # x = 1 - $x -> bzero(@params); + $x = $x -> bzero(@params); $done = 1; } elsif ($x -> is_zero()) { # x = 0 my $sign = defined $base && $base < 1 ? '+' : '-'; - $x -> binf($sign); + $x = $x -> binf($sign); $done = 1; } } @@ -2496,69 +2568,61 @@ sub blog { delete $x->{_a}; delete $x->{_p}; } + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && $x->is_int(); return $x; } # when user set globals, they would interfere with our calculation, so # disable them and later re-enable them no strict 'refs'; - my $abr = "$class\::accuracy"; my $ab = $$abr; $$abr = undef; - my $pbr = "$class\::precision"; my $pb = $$pbr; $$pbr = undef; + my $abr = "$class\::accuracy"; + my $ab = $$abr; + $$abr = undef; + my $pbr = "$class\::precision"; + my $pb = $$pbr; + $$pbr = undef; # we also need to disable any set A or P on $x (_find_round_parameters took # them already into account), since these would interfere, too - delete $x->{_a}; delete $x->{_p}; - # need to disable $upgrade in BigInt, to avoid deep recursion - local $Math::BigInt::upgrade = undef; - local $Math::BigFloat::downgrade = undef; - - # upgrade $x if $x is not a Math::BigFloat (handle BigInt input) - # XXX TODO: rebless! - if (!$x->isa('Math::BigFloat')) { - $x = Math::BigFloat->new($x); - $class = ref($x); - } + delete $x->{_a}; + delete $x->{_p}; $done = 0; - # If the base is defined and an integer, try to calculate integer result - # first. This is very fast, and in case the real result was found, we can - # stop right here. - if (defined $base && $base->is_int() && $x->is_int()) { - my $xint = Math::BigInt -> new($x -> bdstr()); - my $bint = Math::BigInt -> new($base -> bdstr()); - $xint->blog($bint); - - # if we found the exact result, we're done - if ($bint -> bpow($xint) == $x) { - my $xflt = Math::BigFloat -> new($xint -> bdstr()); - $x->{sign} = $xflt->{sign}; - $x->{_m} = $xflt->{_m}; - $x->{_es} = $xflt->{_es}; - $x->{_e} = $xflt->{_e}; + # If both the invocand and the base are integers, try to calculate integer + # result first. This is very fast, and in case the real result was found, we + # can stop right here. + + if (defined($base) && $base -> is_int() && $x -> is_int()) { + my $x_lib = $LIB -> _new($x -> bdstr()); + my $b_lib = $LIB -> _new($base -> bdstr()); + ($x_lib, my $exact) = $LIB -> _log_int($x_lib, $b_lib); + if ($exact) { + $x->{_m} = $x_lib; + $x->{_e} = $LIB -> _zero(); + $x = $x -> bnorm(); $done = 1; } } - if ($done == 0) { + unless ($done) { + # First calculate the log to base e (using reduction by 10 and possibly - # also by 2): - $x->_log_10($scale); + # also by 2), and if a different base was requested, convert the result. - # and if a different base was requested, convert it + $x = $x->_log_10($scale); if (defined $base) { - $base = Math::BigFloat->new($base) - unless $base->isa('Math::BigFloat'); # log_b(x) = ln(x) / ln(b), so compute ln(b) my $base_log_e = $base->copy()->_log_10($scale); - $x->bdiv($base_log_e, $scale); + $x = $x->bdiv($base_log_e, $scale); } } # shortcut to not run through _find_round_parameters again if (defined $params[0]) { - $x->bround($params[0], $params[2]); # then round accordingly + $x = $x->bround($params[0], $params[2]); # then round accordingly } else { - $x->bfround($params[1], $params[2]); # then round accordingly + $x = $x->bfround($params[1], $params[2]); # then round accordingly } if ($fallback) { # clear a/p after round, since user did not request it @@ -2569,25 +2633,28 @@ sub blog { $$abr = $ab; $$pbr = $pb; - $x; + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && $x->is_int(); + return $x; } sub bexp { # Calculate e ** X (Euler's number to the power of X) - my ($class, $x, $a, $p, $r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('bexp'); - return $x->binf() if $x->{sign} eq '+inf'; - return $x->bzero() if $x->{sign} eq '-inf'; + return $x->bnan(@r) if $x -> is_nan(); + return $x->binf(@r) if $x->{sign} eq '+inf'; + return $x->bzero(@r) if $x->{sign} eq '-inf'; # we need to limit the accuracy to protect against overflow my $fallback = 0; my ($scale, @params); - ($x, @params) = $x->_find_round_parameters($a, $p, $r); + ($x, @params) = $x->_find_round_parameters(@r); - # also takes care of the "error in _find_round_parameters?" case - return $x if $x->{sign} eq 'NaN'; + # error in _find_round_parameters? + return $x->bnan(@r) if $x->{sign} eq 'NaN'; # no rounding at all, so must use fallback if (scalar @params == 0) { @@ -2595,7 +2662,7 @@ sub bexp { $params[0] = $class->div_scale(); # and round to it as accuracy $params[1] = undef; # P = undef $scale = $params[0]+4; # at least four more for proper round - $params[2] = $r; # round mode by caller or undef + $params[2] = $r[2]; # round mode by caller or undef $fallback = 1; # to clear a/p afterwards } else { # the 4 below is empirical, and there might be cases where it's not @@ -2613,13 +2680,21 @@ sub bexp { # when user set globals, they would interfere with our calculation, so # disable them and later re-enable them no strict 'refs'; - my $abr = "$class\::accuracy"; my $ab = $$abr; $$abr = undef; - my $pbr = "$class\::precision"; my $pb = $$pbr; $$pbr = undef; + my $abr = "$class\::accuracy"; + my $ab = $$abr; + $$abr = undef; + my $pbr = "$class\::precision"; + my $pb = $$pbr; + $$pbr = undef; # we also need to disable any set A or P on $x (_find_round_parameters took # them already into account), since these would interfere, too delete $x->{_a}; delete $x->{_p}; - # need to disable $upgrade in BigInt, to avoid deep recursion + + # Disabling upgrading and downgrading is no longer necessary to avoid an + # infinite recursion, but it avoids unnecessary upgrading and downgrading in + # the intermediate computations. + local $Math::BigInt::upgrade = undef; local $Math::BigFloat::downgrade = undef; @@ -2682,13 +2757,15 @@ sub bexp { } else { # compute A and B so that e = A / B. - # After some terms we end up with this, so we use it as a starting point: + # After some terms we end up with this, so we use it as a starting + # point: my $A = $LIB->_new("9093339520860578540197197" . "0164779391644753259799242"); my $F = $LIB->_new(42); my $step = 42; - # Compute how many steps we need to take to get $A and $B sufficiently big + # Compute how many steps we need to take to get $A and $B sufficiently + # big my $steps = _len_to_steps($scale - 4); # print STDERR "# Doing $steps steps for ", $scale-4, " digits\n"; while ($step++ <= $steps) { @@ -2698,7 +2775,9 @@ sub bexp { # increment f $F = $LIB->_inc($F); } - # compute $B as factorial of $steps (this is faster than doing it manually) + + # Compute $B as factorial of $steps (this is faster than doing it + # manually) my $B = $LIB->_fac($LIB->_new($steps)); # print "A ", $LIB->_str($A), "\nB ", $LIB->_str($B), "\n"; @@ -2713,7 +2792,8 @@ sub bexp { $x->{_e} = $LIB->_new($scale); } - # $x contains now an estimate of e, with some surplus digits, so we can round + # $x contains now an estimate of e, with some surplus digits, so we can + # round if (!$x_org->is_one()) { # Reduce size of fractional part, followup with integer power of two. my $lshift = 0; @@ -2722,10 +2802,11 @@ sub bexp { } # Raise $x to the wanted power and round it. if ($lshift == 0) { - $x->bpow($x_org, @params); + $x = $x->bpow($x_org, @params); } else { my($mul, $rescale) = (1 << $lshift, $scale+1+$lshift); - $x->bpow(scalar $x_org->bdiv($mul, $rescale), $rescale)->bpow($mul, @params); + $x = $x -> bpow(scalar $x_org->bdiv($mul, $rescale), $rescale) + -> bpow($mul, @params); } } else { # else just round the already computed result @@ -2733,9 +2814,9 @@ sub bexp { delete $x->{_p}; # shortcut to not run through _find_round_parameters again if (defined $params[0]) { - $x->bround($params[0], $params[2]); # then round accordingly + $x = $x->bround($params[0], $params[2]); # then round accordingly } else { - $x->bfround($params[1], $params[2]); # then round accordingly + $x = $x->bfround($params[1], $params[2]); # then round accordingly } } if ($fallback) { @@ -2747,18 +2828,19 @@ sub bexp { $$abr = $ab; $$pbr = $pb; - $x; # return modified $x + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && $x -> is_int(); + $x; } sub bnok { # Calculate n over k (binomial coefficient or "choose" function) as integer. # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; return $x if $x->modify('bnok'); @@ -2768,7 +2850,10 @@ sub bnok { my $xint = Math::BigInt -> new($x -> bsstr()); my $yint = Math::BigInt -> new($y -> bsstr()); - $xint -> bnok($yint); + $xint = $xint -> bnok($yint); + + return $xint if defined $downgrade; + my $xflt = Math::BigFloat -> new($xint); $x->{_m} = $xflt->{_m}; @@ -2787,15 +2872,18 @@ sub bsin { # sin = x - --- + --- - --- + --- ... # 3! 5! 7! 9! + return $x if $x->modify('bsin'); + + return $x -> bzero(@r) if $x->is_zero(); + return $x -> bnan(@r) if $x->is_nan() || $x->is_inf(); + # we need to limit the accuracy to protect against overflow my $fallback = 0; my ($scale, @params); ($x, @params) = $x->_find_round_parameters(@r); - # constant object or error in _find_round_parameters? - return $x if $x->modify('bsin') || $x->is_nan(); - - return $x->bzero(@r) if $x->is_zero(); + # error in _find_round_parameters? + return $x->bnan(@r) if $x->is_nan(); # no rounding at all, so must use fallback if (scalar @params == 0) { @@ -2814,26 +2902,35 @@ sub bsin { # when user set globals, they would interfere with our calculation, so # disable them and later re-enable them no strict 'refs'; - my $abr = "$class\::accuracy"; my $ab = $$abr; $$abr = undef; - my $pbr = "$class\::precision"; my $pb = $$pbr; $$pbr = undef; + my $abr = "$class\::accuracy"; + my $ab = $$abr; + $$abr = undef; + my $pbr = "$class\::precision"; + my $pb = $$pbr; + $$pbr = undef; # we also need to disable any set A or P on $x (_find_round_parameters took # them already into account), since these would interfere, too delete $x->{_a}; delete $x->{_p}; - # need to disable $upgrade in BigInt, to avoid deep recursion + + # Disabling upgrading and downgrading is no longer necessary to avoid an + # infinite recursion, but it avoids unnecessary upgrading and downgrading in + # the intermediate computations. + local $Math::BigInt::upgrade = undef; + local $Math::BigFloat::downgrade = undef; my $over = $x * $x; # X ^ 2 my $x2 = $over->copy(); # X ^ 2; difference between terms - $over->bmul($x); # X ^ 3 as starting value + $over = $over->bmul($x); # X ^ 3 as starting value my $sign = 1; # start with -= - my $below = $class->new(6); my $factorial = $class->new(4); + my $below = $class->new(6); + my $factorial = $class->new(4); delete $x->{_a}; delete $x->{_p}; my $limit = $class->new("1E-". ($scale-1)); - #my $steps = 0; - while (3 < 5) { + while (1) { # 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 # anymore, so we stop: @@ -2841,22 +2938,24 @@ sub bsin { last if $next->bacmp($limit) <= 0; if ($sign == 0) { - $x->badd($next); + $x = $x->badd($next); } else { - $x->bsub($next); + $x = $x->bsub($next); } $sign = 1-$sign; # alternate # calculate things for the next term - $over->bmul($x2); # $x*$x - $below->bmul($factorial); $factorial->binc(); # n*(n+1) - $below->bmul($factorial); $factorial->binc(); # n*(n+1) + $over = $over->bmul($x2); # $x*$x + $below = $below->bmul($factorial); # n*(n+1) + $factorial = $factorial->binc(); + $below = $below -> bmul($factorial); # n*(n+1) + $factorial = $factorial->binc(); } # shortcut to not run through _find_round_parameters again if (defined $params[0]) { - $x->bround($params[0], $params[2]); # then round accordingly + $x = $x->bround($params[0], $params[2]); # then round accordingly } else { - $x->bfround($params[1], $params[2]); # then round accordingly + $x = $x->bfround($params[1], $params[2]); # then round accordingly } if ($fallback) { # clear a/p after round, since user did not request it @@ -2866,6 +2965,9 @@ sub bsin { # restore globals $$abr = $ab; $$pbr = $pb; + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && $x -> is_int(); $x; } @@ -2884,7 +2986,7 @@ sub bcos { # constant object or error in _find_round_parameters? return $x if $x->modify('bcos') || $x->is_nan(); - + return $x->bnan() if $x->is_inf(); return $x->bone(@r) if $x->is_zero(); # no rounding at all, so must use fallback @@ -2904,20 +3006,23 @@ sub bcos { # when user set globals, they would interfere with our calculation, so # disable them and later re-enable them no strict 'refs'; - my $abr = "$class\::accuracy"; my $ab = $$abr; $$abr = undef; - my $pbr = "$class\::precision"; my $pb = $$pbr; $$pbr = undef; + my $abr = "$class\::accuracy"; + my $ab = $$abr; + $$abr = undef; + my $pbr = "$class\::precision"; + my $pb = $$pbr; + $$pbr = undef; # we also need to disable any set A or P on $x (_find_round_parameters took # them already into account), since these would interfere, too - delete $x->{_a}; delete $x->{_p}; - # need to disable $upgrade in BigInt, to avoid deep recursion - local $Math::BigInt::upgrade = undef; + delete $x->{_a}; + delete $x->{_p}; my $over = $x * $x; # X ^ 2 my $x2 = $over->copy(); # X ^ 2; difference between terms my $sign = 1; # start with -= my $below = $class->new(2); my $factorial = $class->new(3); - $x->bone(); + $x = $x->bone(); delete $x->{_a}; delete $x->{_p}; @@ -2931,22 +3036,24 @@ sub bcos { last if $next->bacmp($limit) <= 0; if ($sign == 0) { - $x->badd($next); + $x = $x->badd($next); } else { - $x->bsub($next); + $x = $x->bsub($next); } $sign = 1-$sign; # alternate # calculate things for the next term - $over->bmul($x2); # $x*$x - $below->bmul($factorial); $factorial->binc(); # n*(n+1) - $below->bmul($factorial); $factorial->binc(); # n*(n+1) + $over = $over->bmul($x2); # $x*$x + $below = $below->bmul($factorial); # n*(n+1) + $factorial = $factorial -> binc(); + $below = $below->bmul($factorial); # n*(n+1) + $factorial = $factorial -> binc(); } # shortcut to not run through _find_round_parameters again if (defined $params[0]) { - $x->bround($params[0], $params[2]); # then round accordingly + $x = $x->bround($params[0], $params[2]); # then round accordingly } else { - $x->bfround($params[1], $params[2]); # then round accordingly + $x = $x->bfround($params[1], $params[2]); # then round accordingly } if ($fallback) { # clear a/p after round, since user did not request it @@ -2956,48 +3063,50 @@ sub bcos { # restore globals $$abr = $ab; $$pbr = $pb; + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && $x -> is_int(); $x; } sub batan { # Calculate a arcus tangens of x. - - my $self = shift; - my $selfref = ref $self; - my $class = $selfref || $self; - - my (@r) = @_; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); # taylor: x^3 x^5 x^7 x^9 # atan = x - --- + --- - --- + --- ... # 3 5 7 9 + return $x if $x->modify('batan'); + + return $x -> bnan(@r) if $x->is_nan(); + # We need to limit the accuracy to protect against overflow. my $fallback = 0; my ($scale, @params); - ($self, @params) = $self->_find_round_parameters(@r); + ($x, @params) = $x->_find_round_parameters(@r); - # Constant object or error in _find_round_parameters? + # Error in _find_round_parameters? - return $self if $self->modify('batan') || $self->is_nan(); + return $x -> bnan(@r) if $x->is_nan(); - if ($self->{sign} =~ /^[+-]inf\z/) { + if ($x->{sign} =~ /^[+-]inf\z/) { # +inf result is PI/2 # -inf result is -PI/2 # calculate PI/2 my $pi = $class->bpi(@r); - # modify $self in place - $self->{_m} = $pi->{_m}; - $self->{_e} = $pi->{_e}; - $self->{_es} = $pi->{_es}; + # modify $x in place + $x->{_m} = $pi->{_m}; + $x->{_e} = $pi->{_e}; + $x->{_es} = $pi->{_es}; # -y => -PI/2, +y => PI/2 - $self->{sign} = substr($self->{sign}, 0, 1); # "+inf" => "+" - $self -> {_m} = $LIB->_div($self->{_m}, $LIB->_new(2)); - return $self; + $x->{sign} = substr($x->{sign}, 0, 1); # "+inf" => "+" + $x -> {_m} = $LIB->_div($x->{_m}, $LIB->_new(2)); + return $x; } - return $self->bzero(@r) if $self->is_zero(); + return $x->bzero(@r) if $x->is_zero(); # no rounding at all, so must use fallback if (scalar @params == 0) { @@ -3015,57 +3124,67 @@ sub batan { # 1 or -1 => PI/4 # inlined is_one() && is_one('-') - if ($LIB->_is_one($self->{_m}) && $LIB->_is_zero($self->{_e})) { + if ($LIB->_is_one($x->{_m}) && $LIB->_is_zero($x->{_e})) { my $pi = $class->bpi($scale - 3); - # modify $self in place - $self->{_m} = $pi->{_m}; - $self->{_e} = $pi->{_e}; - $self->{_es} = $pi->{_es}; - # leave the sign of $self alone (+1 => +PI/4, -1 => -PI/4) - $self->{_m} = $LIB->_div($self->{_m}, $LIB->_new(4)); - return $self; + # modify $x in place + $x->{_m} = $pi->{_m}; + $x->{_e} = $pi->{_e}; + $x->{_es} = $pi->{_es}; + # leave the sign of $x alone (+1 => +PI/4, -1 => -PI/4) + $x->{_m} = $LIB->_div($x->{_m}, $LIB->_new(4)); + return $x; } # This series is only valid if -1 < x < 1, so for other x we need to # calculate PI/2 - atan(1/x): my $pi = undef; - if ($self->bacmp($self->copy()->bone) >= 0) { + if ($x->bacmp($x->copy()->bone) >= 0) { # calculate PI/2 $pi = $class->bpi($scale - 3); $pi->{_m} = $LIB->_div($pi->{_m}, $LIB->_new(2)); - # calculate 1/$self: - my $self_copy = $self->copy(); - # modify $self in place - $self->bone(); - $self->bdiv($self_copy, $scale); + # calculate 1/$x: + my $x_copy = $x->copy(); + # modify $x in place + $x = $x->bone(); + $x = $x->bdiv($x_copy, $scale); } my $fmul = 1; foreach (0 .. int($scale / 20)) { $fmul *= 2; - $self->bdiv($self->copy()->bmul($self)->binc->bsqrt($scale + 4)->binc, $scale + 4); + $x = $x->bdiv($x->copy()->bmul($x)->binc()->bsqrt($scale + 4)->binc(), + $scale + 4); } # When user set globals, they would interfere with our calculation, so # disable them and later re-enable them. no strict 'refs'; - my $abr = "$class\::accuracy"; my $ab = $$abr; $$abr = undef; - my $pbr = "$class\::precision"; my $pb = $$pbr; $$pbr = undef; - # We also need to disable any set A or P on $self (_find_round_parameters + my $abr = "$class\::accuracy"; + my $ab = $$abr; + $$abr = undef; + my $pbr = "$class\::precision"; + my $pb = $$pbr; + $$pbr = undef; + # We also need to disable any set A or P on $x (_find_round_parameters # took them already into account), since these would interfere, too - delete $self->{_a}; - delete $self->{_p}; - # Need to disable $upgrade in BigInt, to avoid deep recursion. + delete $x->{_a}; + delete $x->{_p}; + + # Disabling upgrading and downgrading is no longer necessary to avoid an + # infinite recursion, but it avoids unnecessary upgrading and downgrading in + # the intermediate computations. + local $Math::BigInt::upgrade = undef; + local $Math::BigFloat::downgrade = undef; - my $over = $self * $self; # X ^ 2 - my $self2 = $over->copy(); # X ^ 2; difference between terms - $over->bmul($self); # X ^ 3 as starting value + my $over = $x * $x; # X ^ 2 + my $x2 = $over->copy(); # X ^ 2; difference between terms + $over = $over->bmul($x); # X ^ 3 as starting value my $sign = 1; # start with -= my $below = $class->new(3); my $two = $class->new(2); - delete $self->{_a}; - delete $self->{_p}; + delete $x->{_a}; + delete $x->{_p}; my $limit = $class->new("1E-". ($scale-1)); #my $steps = 0; @@ -3077,55 +3196,55 @@ sub batan { last if $next->bacmp($limit) <= 0; if ($sign == 0) { - $self->badd($next); + $x = $x->badd($next); } else { - $self->bsub($next); + $x = $x->bsub($next); } $sign = 1-$sign; # alternatex # calculate things for the next term - $over->bmul($self2); # $self*$self - $below->badd($two); # n += 2 + $over = $over->bmul($x2); # $x*$x + $below = $below->badd($two); # n += 2 } - $self->bmul($fmul); + $x = $x->bmul($fmul); if (defined $pi) { - my $self_copy = $self->copy(); - # modify $self in place - $self->{_m} = $pi->{_m}; - $self->{_e} = $pi->{_e}; - $self->{_es} = $pi->{_es}; - # PI/2 - $self - $self->bsub($self_copy); + my $x_copy = $x->copy(); + # modify $x in place + $x->{_m} = $pi->{_m}; + $x->{_e} = $pi->{_e}; + $x->{_es} = $pi->{_es}; + # PI/2 - $x + $x = $x->bsub($x_copy); } # Shortcut to not run through _find_round_parameters again. if (defined $params[0]) { - $self->bround($params[0], $params[2]); # then round accordingly + $x = $x->bround($params[0], $params[2]); # then round accordingly } else { - $self->bfround($params[1], $params[2]); # then round accordingly + $x = $x->bfround($params[1], $params[2]); # then round accordingly } if ($fallback) { # Clear a/p after round, since user did not request it. - delete $self->{_a}; - delete $self->{_p}; + delete $x->{_a}; + delete $x->{_p}; } # restore globals $$abr = $ab; $$pbr = $pb; - $self; + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && ($x -> is_int() || $x -> is_inf()); + $x; } sub batan2 { # $y -> batan2($x) returns the arcus tangens of $y / $x. # Set up parameters. - my ($class, $y, $x, @r) = (ref($_[0]), @_); - - # Objectify is costly, so avoid it if we can. - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $y, $x, @r) = objectify(2, @_); - } + my ($class, $y, $x, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); # Quick exit if $y is read-only. return $y if $y -> modify('batan2'); @@ -3155,52 +3274,52 @@ sub batan2 { $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined } - if ($x -> is_inf("+")) { # x = inf - if ($y -> is_inf("+")) { # y = inf - $y -> bpi($scale) -> bmul("0.25"); # pi/4 - } elsif ($y -> is_inf("-")) { # y = -inf - $y -> bpi($scale) -> bmul("-0.25"); # -pi/4 - } else { # -inf < y < inf - return $y -> bzero(@r); # 0 + if ($x -> is_inf("+")) { # x = inf + if ($y -> is_inf("+")) { # y = inf + $y = $y -> bpi($scale) -> bmul("0.25"); # pi/4 + } elsif ($y -> is_inf("-")) { # y = -inf + $y = $y -> bpi($scale) -> bmul("-0.25"); # -pi/4 + } else { # -inf < y < inf + return $y -> bzero(@r); # 0 } - } elsif ($x -> is_inf("-")) { # x = -inf - if ($y -> is_inf("+")) { # y = inf - $y -> bpi($scale) -> bmul("0.75"); # 3/4 pi - } elsif ($y -> is_inf("-")) { # y = -inf - $y -> bpi($scale) -> bmul("-0.75"); # -3/4 pi - } elsif ($y >= 0) { # y >= 0 - $y -> bpi($scale); # pi - } else { # y < 0 - $y -> bpi($scale) -> bneg(); # -pi + } elsif ($x -> is_inf("-")) { # x = -inf + if ($y -> is_inf("+")) { # y = inf + $y = $y -> bpi($scale) -> bmul("0.75"); # 3/4 pi + } elsif ($y -> is_inf("-")) { # y = -inf + $y = $y -> bpi($scale) -> bmul("-0.75"); # -3/4 pi + } elsif ($y >= 0) { # y >= 0 + $y = $y -> bpi($scale); # pi + } else { # y < 0 + $y = $y -> bpi($scale) -> bneg(); # -pi } - } elsif ($x > 0) { # 0 < x < inf - if ($y -> is_inf("+")) { # y = inf - $y -> bpi($scale) -> bmul("0.5"); # pi/2 - } elsif ($y -> is_inf("-")) { # y = -inf - $y -> bpi($scale) -> bmul("-0.5"); # -pi/2 - } else { # -inf < y < inf - $y -> bdiv($x, $scale) -> batan($scale); # atan(y/x) + } elsif ($x > 0) { # 0 < x < inf + if ($y -> is_inf("+")) { # y = inf + $y = $y -> bpi($scale) -> bmul("0.5"); # pi/2 + } elsif ($y -> is_inf("-")) { # y = -inf + $y = $y -> bpi($scale) -> bmul("-0.5"); # -pi/2 + } else { # -inf < y < inf + $y = $y -> bdiv($x, $scale) -> batan($scale); # atan(y/x) } - } elsif ($x < 0) { # -inf < x < 0 + } elsif ($x < 0) { # -inf < x < 0 my $pi = $class -> bpi($scale); - if ($y >= 0) { # y >= 0 - $y -> bdiv($x, $scale) -> batan() # atan(y/x) + pi + if ($y >= 0) { # y >= 0 + $y = $y -> bdiv($x, $scale) -> batan() # atan(y/x) + pi -> badd($pi); - } else { # y < 0 - $y -> bdiv($x, $scale) -> batan() # atan(y/x) - pi + } else { # y < 0 + $y = $y -> bdiv($x, $scale) -> batan() # atan(y/x) - pi -> bsub($pi); } - } else { # x = 0 - if ($y > 0) { # y > 0 - $y -> bpi($scale) -> bmul("0.5"); # pi/2 - } elsif ($y < 0) { # y < 0 - $y -> bpi($scale) -> bmul("-0.5"); # -pi/2 - } else { # y = 0 - return $y -> bzero(@r); # 0 + } else { # x = 0 + if ($y > 0) { # y > 0 + $y = $y -> bpi($scale) -> bmul("0.5"); # pi/2 + } elsif ($y < 0) { # y < 0 + $y = $y -> bpi($scale) -> bmul("-0.5"); # -pi/2 + } else { # y = 0 + return $y -> bzero(@r); # 0 } } - $y -> round(@r); + $y = $y -> round(@r); if ($fallback) { delete $y->{_a}; @@ -3209,31 +3328,40 @@ sub batan2 { return $y; } -############################################################################## sub bsqrt { # calculate square root - my ($class, $x, $a, $p, $r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('bsqrt'); - 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(); + # Handle trivial cases. + + return $x -> bnan(@r) if $x->is_nan(); + return $x -> binf("+", @r) if $x->{sign} eq '+inf'; + return $x -> round(@r) if $x->is_zero() || $x->is_one(); + + # We don't support complex numbers. + + if ($x -> is_neg()) { + return $upgrade -> bsqrt($x, @r) if defined($upgrade); + return $x -> bnan(@r); + } # we need to limit the accuracy to protect against overflow my $fallback = 0; my (@params, $scale); - ($x, @params) = $x->_find_round_parameters($a, $p, $r); + ($x, @params) = $x->_find_round_parameters(@r); - return $x if $x->is_nan(); # error in _find_round_parameters? + # error in _find_round_parameters? + return $x -> bnan(@r) if $x->is_nan(); # no rounding at all, so must use fallback if (scalar @params == 0) { # simulate old behaviour $params[0] = $class->div_scale(); # and round to it as accuracy $scale = $params[0]+4; # at least four more for proper round - $params[2] = $r; # round mode by caller or undef + $params[2] = $r[2]; # round mode by caller or undef $fallback = 1; # to clear a/p afterwards } else { # the 4 below is empirical, and there might be cases where it is not @@ -3244,14 +3372,23 @@ sub bsqrt { # when user set globals, they would interfere with our calculation, so # disable them and later re-enable them no strict 'refs'; - my $abr = "$class\::accuracy"; my $ab = $$abr; $$abr = undef; - my $pbr = "$class\::precision"; my $pb = $$pbr; $$pbr = undef; + my $abr = "$class\::accuracy"; + my $ab = $$abr; + $$abr = undef; + my $pbr = "$class\::precision"; + my $pb = $$pbr; + $$pbr = undef; # we also need to disable any set A or P on $x (_find_round_parameters took # them already into account), since these would interfere, too delete $x->{_a}; delete $x->{_p}; - # need to disable $upgrade in BigInt, to avoid deep recursion - local $Math::BigInt::upgrade = undef; # should be really parent class vs MBI + + # Disabling upgrading and downgrading is no longer necessary to avoid an + # infinite recursion, but it avoids unnecessary upgrading and downgrading in + # the intermediate computations. + + local $Math::BigInt::upgrade = undef; + local $Math::BigFloat::downgrade = undef; my $i = $LIB->_copy($x->{_m}); $i = $LIB->_lsft($i, $x->{_e}, 10) unless $LIB->_is_zero($x->{_e}); @@ -3268,12 +3405,12 @@ sub bsqrt { $x->{_m} = $gs->{value}; $x->{_e} = $LIB->_zero(); $x->{_es} = '+'; - $x->bnorm(); + $x = $x->bnorm(); # shortcut to not run through _find_round_parameters again if (defined $params[0]) { - $x->bround($params[0], $params[2]); # then round accordingly + $x = $x->bround($params[0], $params[2]); # then round accordingly } else { - $x->bfround($params[1], $params[2]); # then round accordingly + $x = $x->bfround($params[1], $params[2]); # then round accordingly } if ($fallback) { # clear a/p after round, since user did not request it @@ -3286,9 +3423,10 @@ sub bsqrt { return $x; } - # sqrt(2) = 1.4 because sqrt(2*100) = 1.4*10; so we can increase the accuracy - # of the result by multiplying the input by 100 and then divide the integer - # result of sqrt(input) by 10. Rounding afterwards returns the real result. + # sqrt(2) = 1.4 because sqrt(2*100) = 1.4*10; so we can increase the + # accuracy of the result by multiplying the input by 100 and then divide the + # integer result of sqrt(input) by 10. Rounding afterwards returns the real + # result. # The following steps will transform 123.456 (in $x) into 123456 (in $y1) my $y1 = $LIB->_copy($x->{_m}); @@ -3348,13 +3486,13 @@ sub bsqrt { $x->{_es} = '+'; } $x->{_m} = $y1; - $x->bnorm(); + $x = $x->bnorm(); # shortcut to not run through _find_round_parameters again if (defined $params[0]) { - $x->bround($params[0], $params[2]); # then round accordingly + $x = $x->bround($params[0], $params[2]); # then round accordingly } else { - $x->bfround($params[1], $params[2]); # then round accordingly + $x = $x->bfround($params[1], $params[2]); # then round accordingly } if ($fallback) { # clear a/p after round, since user did not request it @@ -3364,6 +3502,9 @@ sub bsqrt { # restore globals $$abr = $ab; $$pbr = $pb; + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && ($x -> is_int() || $x -> is_inf()); $x; } @@ -3371,14 +3512,24 @@ sub broot { # calculate $y'th root of $x # set up parameters - my ($class, $x, $y, $a, $p, $r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, $a, $p, $r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x->modify('broot'); + # Handle trivial cases. + + return $x -> bnan(@r) if $x->is_nan() || $y->is_nan(); + + if ($x -> is_neg()) { + # -27 ** (1/3) = -3 + return $x -> broot($y -> copy() -> bneg(), @r) -> bneg() + if $x -> is_int() && $y -> is_int() && $y -> is_neg(); + return $upgrade -> broot($x, $y, @r) if defined $upgrade; + return $x -> bnan(@r); + } + # NaN handling: $x ** 1/0, x or y NaN, or y inf/-inf or y == 0 return $x->bnan() if $x->{sign} !~ /^\+/ || $y->is_zero() || $y->{sign} !~ /^\+$/; @@ -3388,7 +3539,7 @@ sub broot { # we need to limit the accuracy to protect against overflow my $fallback = 0; my (@params, $scale); - ($x, @params) = $x->_find_round_parameters($a, $p, $r); + ($x, @params) = $x->_find_round_parameters(@r); return $x if $x->is_nan(); # error in _find_round_parameters? @@ -3397,7 +3548,7 @@ sub broot { # simulate old behaviour $params[0] = $class->div_scale(); # and round to it as accuracy $scale = $params[0]+4; # at least four more for proper round - $params[2] = $r; # round mode by caller or undef + $params[2] = $r[2]; # round mode by caller or undef $fallback = 1; # to clear a/p afterwards } else { # the 4 below is empirical, and there might be cases where it is not @@ -3408,14 +3559,23 @@ sub broot { # when user set globals, they would interfere with our calculation, so # disable them and later re-enable them no strict 'refs'; - my $abr = "$class\::accuracy"; my $ab = $$abr; $$abr = undef; - my $pbr = "$class\::precision"; my $pb = $$pbr; $$pbr = undef; + my $abr = "$class\::accuracy"; + my $ab = $$abr; + $$abr = undef; + my $pbr = "$class\::precision"; + my $pb = $$pbr; + $$pbr = undef; # we also need to disable any set A or P on $x (_find_round_parameters took # them already into account), since these would interfere, too delete $x->{_a}; delete $x->{_p}; - # need to disable $upgrade in BigInt, to avoid deep recursion - local $Math::BigInt::upgrade = undef; # should be really parent class vs MBI + + # Disabling upgrading and downgrading is no longer necessary to avoid an + # infinite recursion, but it avoids unnecessary upgrading and downgrading in + # the intermediate computations. + + local $Math::BigInt::upgrade = undef; + local $Math::BigFloat::downgrade = undef; # remember sign and make $x positive, since -4 ** (1/2) => -2 my $sign = 0; @@ -3424,14 +3584,15 @@ sub broot { my $is_two = 0; if ($y->isa('Math::BigFloat')) { - $is_two = ($y->{sign} eq '+' && $LIB->_is_two($y->{_m}) && $LIB->_is_zero($y->{_e})); + $is_two = $y->{sign} eq '+' && $LIB->_is_two($y->{_m}) + && $LIB->_is_zero($y->{_e}); } else { - $is_two = ($y == 2); + $is_two = $y == 2; } # normal square root if $y == 2: if ($is_two) { - $x->bsqrt($scale+4); + $x = $x->bsqrt($scale+4); } elsif ($y->is_one('-')) { # $x ** -1 => 1/$x my $u = $class->bone()->bdiv($x, $scale); @@ -3449,30 +3610,31 @@ sub broot { $i = $LIB->_lsft($i, $x->{_e}, 10) unless $LIB->_is_zero($x->{_e}); my $int = Math::BigInt->bzero(); $int->{value} = $i; - $int->broot($y->as_number()); + $int = $int->broot($y->as_number()); # if ($exact) if ($int->copy()->bpow($y) == $x) { # found result, return it $x->{_m} = $int->{value}; $x->{_e} = $LIB->_zero(); $x->{_es} = '+'; - $x->bnorm(); + $x = $x->bnorm(); $done = 1; } } if ($done == 0) { my $u = $class->bone()->bdiv($y, $scale+4); - delete $u->{_a}; delete $u->{_p}; # otherwise it conflicts - $x->bpow($u, $scale+4); # el cheapo + delete $u->{_a}; + delete $u->{_p}; + $x = $x->bpow($u, $scale+4); # el cheapo } } - $x->bneg() if $sign == 1; + $x = $x->bneg() if $sign == 1; # shortcut to not run through _find_round_parameters again if (defined $params[0]) { - $x->bround($params[0], $params[2]); # then round accordingly + $x = $x->bround($params[0], $params[2]); # then round accordingly } else { - $x->bfround($params[1], $params[2]); # then round accordingly + $x = $x->bfround($params[1], $params[2]); # then round accordingly } if ($fallback) { # clear a/p after round, since user did not request it @@ -3482,6 +3644,9 @@ sub broot { # restore globals $$abr = $ab; $$pbr = $pb; + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && ($x -> is_int() || $x -> is_inf()); $x; } @@ -3490,16 +3655,19 @@ sub bfac { # compute factorial number, modifies first argument # set up parameters - my ($class, $x, @r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - ($class, $x, @r) = objectify(1, @_) if !ref($x); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); # inf => inf - return $x if $x->modify('bfac') || $x->{sign} eq '+inf'; + return $x if $x->modify('bfac'); + + return $x -> bnan(@r) if $x->is_nan() || $x->is_inf("-"); + return $x -> binf("+", @r) if $x->is_inf("+"); + return $x -> bone(@r) if $x->is_zero() || $x->is_one(); - return $x->bnan() - if (($x->{sign} ne '+') || # inf, NaN, <0 etc => NaN - ($x->{_es} ne '+')); # digits after dot? + if ($x -> is_neg() || !$x -> is_int()) { + return $upgrade -> bfac($x, @r) if defined($upgrade); + return $x -> bnan(@r); + } if (! $LIB->_is_zero($x->{_e})) { $x->{_m} = $LIB->_lsft($x->{_m}, $x->{_e}, 10); # change 12e1 to 120e0 @@ -3507,23 +3675,31 @@ sub bfac { $x->{_es} = '+'; } $x->{_m} = $LIB->_fac($x->{_m}); # calculate factorial - $x->bnorm()->round(@r); # norm again and round result + + $x = $x->bnorm()->round(@r); # norm again and round result + + return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade) + && ($x -> is_int() || $x -> is_inf()); + $x; } sub bdfac { # compute double factorial # set up parameters - my ($class, $x, @r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - ($class, $x, @r) = objectify(1, @_) if !ref($x); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - # inf => inf - return $x if $x->modify('bfac') || $x->{sign} eq '+inf'; + return $x if $x->modify('bdfac'); + + return $x -> bnan(@r) if $x->is_nan() || $x->is_inf("-"); + return $x -> binf("+", @r) if $x->is_inf("+"); + + if ($x <= -2 || !$x -> is_int()) { + return $upgrade -> bdfac($x, @r) if defined($upgrade); + return $x -> bnan(@r); + } - return $x->bnan() - if (($x->{sign} ne '+') || # inf, NaN, <0 etc => NaN - ($x->{_es} ne '+')); # digits after dot? + return $x->bone() if $x <= 1; croak("bdfac() requires a newer version of the $LIB library.") unless $LIB->can('_dfac'); @@ -3534,59 +3710,137 @@ sub bdfac { $x->{_es} = '+'; } $x->{_m} = $LIB->_dfac($x->{_m}); # calculate factorial - $x->bnorm()->round(@r); # norm again and round result + + $x = $x->bnorm()->round(@r); # norm again and round result + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && $x -> is_int(); + return $x; } -sub blsft { - # shift left by $y (multiply by $b ** $y) +sub btfac { + # compute triple factorial # set up parameters - my ($class, $x, $y, $b, $a, $p, $r) = (ref($_[0]), @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, $b, $a, $p, $r) = objectify(2, @_); + return $x if $x->modify('btfac'); + + return $x -> bnan(@r) if $x->is_nan() || $x->is_inf("-"); + return $x -> binf("+", @r) if $x->is_inf("+"); + + if ($x <= -3 || !$x -> is_int()) { + return $upgrade -> btfac($x, @r) if defined($upgrade); + return $x -> bnan(@r); + } + + my $k = $class -> new("3"); + return $x->bnan(@r) if $x <= -$k; + + my $one = $class -> bone(); + return $x->bone(@r) if $x <= $one; + + my $f = $x -> copy(); + while ($f -> bsub($k) > $one) { + $x = $x -> bmul($f); } + $x = $x->round(@r); + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && $x -> is_int(); + return $x; +} + +sub bmfac { + my ($class, $x, $k, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); + + return $x if $x->modify('bmfac'); + + return $x -> bnan(@r) if $x->is_nan() || $x->is_inf("-") || !$k->is_pos(); + return $x -> binf("+", @r) if $x->is_inf("+"); + + if ($x <= -$k || !$x -> is_int() || + ($k -> is_finite() && !$k -> is_int())) + { + return $upgrade -> bmfac($x, $k, @r) if defined($upgrade); + return $x -> bnan(@r); + } + + my $one = $class -> bone(); + return $x->bone(@r) if $x <= $one; + + my $f = $x -> copy(); + while ($f -> bsub($k) > $one) { + $x = $x -> bmul($f); + } + + $x = $x->round(@r); + + return $downgrade -> new($x -> bdstr(), @r) + if defined($downgrade) && $x -> is_int(); + return $x; +} + +sub blsft { + # shift left by $y (multiply by $b ** $y) + + # set up parameters + my ($class, $x, $y, $b, @r) + = ref($_[0]) && ref($_[0]) eq ref($_[1]) && ref($_[1]) eq ref($_[2]) + ? (ref($_[0]), @_) + : objectify(2, @_); + return $x if $x -> modify('blsft'); - return $x if $x -> {sign} !~ /^[+-]$/; # nan, +inf, -inf + + return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); $b = 2 if !defined $b; $b = $class -> new($b) unless ref($b) && $b -> isa($class); + return $x -> bnan(@r) if $b -> is_nan(); - return $x -> bnan() if $x -> is_nan() || $y -> is_nan() || $b -> is_nan(); + # There needs to be more checking for special cases here. Fixme! # shift by a negative amount? return $x -> brsft($y -> copy() -> babs(), $b) if $y -> {sign} =~ /^-/; - $x -> bmul($b -> bpow($y), $a, $p, $r, $y); + $x = $x -> bmul($b -> bpow($y), $r[0], $r[1], $r[2], $y); + + return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade) + && ($x -> is_int() || $x -> is_inf() || $x -> is_nan()); + return $x; } sub brsft { # shift right by $y (divide $b ** $y) # set up parameters - my ($class, $x, $y, $b, $a, $p, $r) = (ref($_[0]), @_); - - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, $b, $a, $p, $r) = objectify(2, @_); - } + my ($class, $x, $y, $b, @r) + = ref($_[0]) && ref($_[0]) eq ref($_[1]) && ref($_[1]) eq ref($_[2]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x -> modify('brsft'); - return $x if $x -> {sign} !~ /^[+-]$/; # nan, +inf, -inf + + return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); + + # There needs to be more checking for special cases here. Fixme! $b = 2 if !defined $b; $b = $class -> new($b) unless ref($b) && $b -> isa($class); - - return $x -> bnan() if $x -> is_nan() || $y -> is_nan() || $b -> is_nan(); + return $x -> bnan(@r) if $b -> is_nan(); # shift by a negative amount? return $x -> blsft($y -> copy() -> babs(), $b) if $y -> {sign} =~ /^-/; - # the following call to bdiv() will return either quotient (scalar context) - # or quotient and remainder (list context). - $x -> bdiv($b -> bpow($y), $a, $p, $r, $y); + # call bdiv() + $x = $x -> bdiv($b -> bpow($y), $r[0], $r[1], $r[2], $y); + + return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade) + && ($x -> is_int() || $x -> is_inf() || $x -> is_nan()); + return $x; } ############################################################################### @@ -3594,24 +3848,20 @@ sub brsft { ############################################################################### sub band { - my $x = shift; - my $xref = ref($x); - my $class = $xref || $x; - - croak 'band() is an instance method, not a class method' unless $xref; - croak 'Not enough arguments for band()' if @_ < 1; + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return if $x -> modify('band'); - my $y = shift; - $y = $class -> new($y) unless ref($y); - - my @r = @_; + return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); my $xtmp = Math::BigInt -> new($x -> bint()); # to Math::BigInt - $xtmp -> band($y); - $xtmp = $class -> new($xtmp); # back to Math::BigFloat + $xtmp = $xtmp -> band($y); + + return $xtmp -> round(@r) if defined $downgrade; + $xtmp = $class -> new($xtmp); # back to Math::BigFloat $x -> {sign} = $xtmp -> {sign}; $x -> {_m} = $xtmp -> {_m}; $x -> {_es} = $xtmp -> {_es}; @@ -3621,24 +3871,20 @@ sub band { } sub bior { - my $x = shift; - my $xref = ref($x); - my $class = $xref || $x; - - croak 'bior() is an instance method, not a class method' unless $xref; - croak 'Not enough arguments for bior()' if @_ < 1; + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return if $x -> modify('bior'); - my $y = shift; - $y = $class -> new($y) unless ref($y); - - my @r = @_; + return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); my $xtmp = Math::BigInt -> new($x -> bint()); # to Math::BigInt - $xtmp -> bior($y); - $xtmp = $class -> new($xtmp); # back to Math::BigFloat + $xtmp = $xtmp -> bior($y); + + return $xtmp -> round(@r) if defined $downgrade; + $xtmp = $class -> new($xtmp); # back to Math::BigFloat $x -> {sign} = $xtmp -> {sign}; $x -> {_m} = $xtmp -> {_m}; $x -> {_es} = $xtmp -> {_es}; @@ -3648,24 +3894,20 @@ sub bior { } sub bxor { - my $x = shift; - my $xref = ref($x); - my $class = $xref || $x; - - croak 'bxor() is an instance method, not a class method' unless $xref; - croak 'Not enough arguments for bxor()' if @_ < 1; + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return if $x -> modify('bxor'); - my $y = shift; - $y = $class -> new($y) unless ref($y); - - my @r = @_; + return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); my $xtmp = Math::BigInt -> new($x -> bint()); # to Math::BigInt - $xtmp -> bxor($y); - $xtmp = $class -> new($xtmp); # back to Math::BigFloat + $xtmp = $xtmp -> bxor($y); + return $xtmp -> round(@r) if defined $downgrade; + + $xtmp = $class -> new($xtmp); # back to Math::BigFloat $x -> {sign} = $xtmp -> {sign}; $x -> {_m} = $xtmp -> {_m}; $x -> {_es} = $xtmp -> {_es}; @@ -3675,20 +3917,18 @@ sub bxor { } sub bnot { - my $x = shift; - my $xref = ref($x); - my $class = $xref || $x; - - croak 'bnot() is an instance method, not a class method' unless $xref; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return if $x -> modify('bnot'); - my @r = @_; + return $x -> bnan(@r) if $x -> is_nan(); my $xtmp = Math::BigInt -> new($x -> bint()); # to Math::BigInt - $xtmp -> bnot(); - $xtmp = $class -> new($xtmp); # back to Math::BigFloat + $xtmp = $xtmp -> bnot(); + return $xtmp -> round(@r) if defined $downgrade; + + $xtmp = $class -> new($xtmp); # back to Math::BigFloat $x -> {sign} = $xtmp -> {sign}; $x -> {_m} = $xtmp -> {_m}; $x -> {_es} = $xtmp -> {_es}; @@ -3703,42 +3943,61 @@ sub bnot { sub bround { # accuracy: preserve $N digits, and overwrite the rest with 0's - my $x = shift; - my $class = ref($x) || $x; - $x = $class->new(shift) if !ref($x); - if (($_[0] || 0) < 0) { + my ($class, $x, @a) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + if (($a[0] || 0) < 0) { croak('bround() needs positive accuracy'); } - my ($scale, $mode) = $x->_scale_a(@_); - return $x if !defined $scale || $x->modify('bround'); # no-op + return $x if $x->modify('bround'); + + my ($scale, $mode) = $x->_scale_a(@a); + if (!defined $scale) { # no-op + return $downgrade -> new($x) if defined($downgrade) + && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; + } - # scale is now either $x->{_a}, $accuracy, or the user parameter - # test whether $x already has lower accuracy, do nothing in this case - # but do round if the accuracy is the same, since a math operation might - # want to round a number with A=5 to 5 digits afterwards again - return $x if defined $x->{_a} && $x->{_a} < $scale; + # Scale is now either $x->{_a}, $accuracy, or the input argument. Test + # whether $x already has lower accuracy, do nothing in this case but do + # round if the accuracy is the same, since a math operation might want to + # round a number with A=5 to 5 digits afterwards again + + if (defined $x->{_a} && $x->{_a} < $scale) { + return $downgrade -> new($x) if defined($downgrade) + && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; + } # scale < 0 makes no sense # scale == 0 => keep all digits # never round a +-inf, NaN - return $x if ($scale <= 0) || $x->{sign} !~ /^[+-]$/; + + if ($scale <= 0 || $x->{sign} !~ /^[+-]$/) { + return $downgrade -> new($x) if defined($downgrade) + && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; + } # 1: never round a 0 # 2: if we should keep more digits than the mantissa has, do nothing if ($x->is_zero() || $LIB->_len($x->{_m}) <= $scale) { $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale; + return $downgrade -> new($x) if defined($downgrade) + && ($x->is_int() || $x->is_inf() || $x->is_nan()); return $x; } # pass sign to bround for '+inf' and '-inf' rounding modes my $m = bless { sign => $x->{sign}, value => $x->{_m} }, 'Math::BigInt'; - $m->bround($scale, $mode); # round mantissa - $x->{_m} = $m->{value}; # get our mantissa back - $x->{_a} = $scale; # remember rounding - delete $x->{_p}; # and clear P + $m = $m->bround($scale, $mode); # round mantissa + $x->{_m} = $m->{value}; # get our mantissa back + $x->{_a} = $scale; # remember rounding + delete $x->{_p}; # and clear P + + # bnorm() downgrades if necessary, so no need to check whether to downgrade. $x->bnorm(); # del trailing zeros gen. by bround() } @@ -3746,29 +4005,50 @@ sub bfround { # precision: round to the $Nth digit left (+$n) or right (-$n) from the '.' # $n == 0 means round to integer # expects and returns normalized numbers! - my $x = shift; - my $class = ref($x) || $x; - $x = $class->new(shift) if !ref($x); - my ($scale, $mode) = $x->_scale_p(@_); - return $x if !defined $scale || $x->modify('bfround'); # no-op + my ($class, $x, @p) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + return $x if $x->modify('bfround'); # no-op + + my ($scale, $mode) = $x->_scale_p(@p); + if (!defined $scale) { + return $downgrade -> new($x) if defined($downgrade) + && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; + } # never round a 0, +-inf, NaN + if ($x->is_zero()) { $x->{_p} = $scale if !defined $x->{_p} || $x->{_p} < $scale; # -3 < -2 + return $downgrade -> new($x) if defined($downgrade) + && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; + } + + if ($x->{sign} !~ /^[+-]$/) { + return $downgrade -> new($x) if defined($downgrade) + && ($x->is_int() || $x->is_inf() || $x->is_nan()); return $x; } - return $x if $x->{sign} !~ /^[+-]$/; # don't round if x already has lower precision - return $x if (defined $x->{_p} && $x->{_p} < 0 && $scale < $x->{_p}); + if (defined $x->{_p} && $x->{_p} < 0 && $scale < $x->{_p}) { + return $downgrade -> new($x) if defined($downgrade) + && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; + } $x->{_p} = $scale; # remember round in any case delete $x->{_a}; # and clear A if ($scale < 0) { # round right from the '.' - return $x if $x->{_es} eq '+'; # e >= 0 => nothing to round + if ($x->{_es} eq '+') { # e >= 0 => nothing to round + return $downgrade -> new($x) if defined($downgrade) + && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; + } $scale = -$scale; # positive for simplicity my $len = $LIB->_len($x->{_m}); # length of mantissa @@ -3788,13 +4068,23 @@ sub bfround { # 1.2345 12345e-4 5 0 4 # do not round after/right of the $dad - return $x if $scale > $dad; # 0.123, scale >= 3 => exit + + if ($scale > $dad) { # 0.123, scale >= 3 => exit + return $downgrade -> new($x) if defined($downgrade) + && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; + } # round to zero if rounding inside the $zad, but not for last zero like: - # 0.0065, scale -2, round last '0' with following '65' (scale == zad case) - return $x->bzero() if $scale < $zad; - if ($scale == $zad) # for 0.006, scale -3 and trunc - { + # 0.0065, scale -2, round last '0' with following '65' (scale == zad + # case) + if ($scale < $zad) { + return $downgrade -> new($x) if defined($downgrade) + && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x->bzero(); + } + + if ($scale == $zad) { # for 0.006, scale -3 and trunc $scale = -$len; } else { # adjust round-point to be inside mantissa @@ -3817,12 +4107,17 @@ sub bfround { # should be the same, so treat it as this $scale = 1 if $scale == 0; # shortcut if already integer - return $x if $scale == 1 && $dbt <= $dbd; + if ($scale == 1 && $dbt <= $dbd) { + return $downgrade -> new($x) if defined($downgrade) + && ($x->is_int() || $x->is_inf() || $x->is_nan()); + return $x; + } # maximum digits before dot ++$dbd; if ($scale > $dbd) { # not enough digits before dot, so round to zero + return $downgrade -> new($x) if defined($downgrade); return $x->bzero; } elsif ($scale == $dbd) { # maximum @@ -3831,66 +4126,87 @@ sub bfround { $scale = $dbd - $scale; } } + # pass sign to bround for rounding modes '+inf' and '-inf' my $m = bless { sign => $x->{sign}, value => $x->{_m} }, 'Math::BigInt'; - $m->bround($scale, $mode); + $m = $m->bround($scale, $mode); $x->{_m} = $m->{value}; # get our mantissa back + + # bnorm() downgrades if necessary, so no need to check whether to downgrade. $x->bnorm(); } sub bfloor { # round towards minus infinity - my ($class, $x, $a, $p, $r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('bfloor'); - return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf - # if $x has digits after dot - if ($x->{_es} eq '-') { - $x->{_m} = $LIB->_rsft($x->{_m}, $x->{_e}, 10); # cut off digits after dot - $x->{_e} = $LIB->_zero(); # trunc/norm - $x->{_es} = '+'; # abs e - $x->{_m} = $LIB->_inc($x->{_m}) if $x->{sign} eq '-'; # increment if negative + return $x -> bnan(@r) if $x -> is_nan(); + + if ($x->{sign} =~ /^[+-]$/) { + # if $x has digits after dot, remove them + if ($x->{_es} eq '-') { + $x->{_m} = $LIB->_rsft($x->{_m}, $x->{_e}, 10); + $x->{_e} = $LIB->_zero(); + $x->{_es} = '+'; + # increment if negative + $x->{_m} = $LIB->_inc($x->{_m}) if $x->{sign} eq '-'; + } + $x = $x->round(@r); } - $x->round($a, $p, $r); + return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade); + return $x; } sub bceil { # round towards plus infinity - my ($class, $x, $a, $p, $r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('bceil'); - return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf - # if $x has digits after dot - if ($x->{_es} eq '-') { - $x->{_m} = $LIB->_rsft($x->{_m}, $x->{_e}, 10); # cut off digits after dot - $x->{_e} = $LIB->_zero(); # trunc/norm - $x->{_es} = '+'; # abs e - if ($x->{sign} eq '+') { - $x->{_m} = $LIB->_inc($x->{_m}); # increment if positive - } else { - $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # avoid -0 + return $x -> bnan(@r) if $x -> is_nan(); + + # if $x has digits after dot, remove them + if ($x->{sign} =~ /^[+-]$/) { + if ($x->{_es} eq '-') { + $x->{_m} = $LIB->_rsft($x->{_m}, $x->{_e}, 10); + $x->{_e} = $LIB->_zero(); + $x->{_es} = '+'; + if ($x->{sign} eq '+') { + $x->{_m} = $LIB->_inc($x->{_m}); # increment if positive + } else { + $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # avoid -0 + } } + $x = $x->round(@r); } - $x->round($a, $p, $r); + + return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade); + return $x; } sub bint { # round towards zero - my ($class, $x, $a, $p, $r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('bint'); - return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf - # if $x has digits after the decimal point - if ($x->{_es} eq '-') { - $x->{_m} = $LIB->_rsft($x->{_m}, $x->{_e}, 10); # cut off digits after dot - $x->{_e} = $LIB->_zero(); # truncate/normalize - $x->{_es} = '+'; # abs e - $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # avoid -0 + return $x -> bnan(@r) if $x -> is_nan(); + + if ($x->{sign} =~ /^[+-]$/) { + # if $x has digits after the decimal point + if ($x->{_es} eq '-') { + $x->{_m} = $LIB->_rsft($x->{_m}, $x->{_e}, 10); # remove frac part + $x->{_e} = $LIB->_zero(); # truncate/normalize + $x->{_es} = '+'; # abs e + $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # avoid -0 + } + $x = $x->round(@r); } - $x->round($a, $p, $r); + + return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade); + return $x; } ############################################################################### @@ -3901,8 +4217,14 @@ sub bgcd { # (BINT or num_str, BINT or num_str) return BINT # does not modify arguments, but returns new object - unshift @_, __PACKAGE__ - unless ref($_[0]) || $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i; + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) + { + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; + unshift @_, __PACKAGE__; + } my ($class, @args) = objectify(0, @_); @@ -3922,7 +4244,11 @@ sub bgcd { last if $x -> is_one(); } - return $x -> babs(); + $x = $x -> babs(); + + return $downgrade -> new($x) + if defined $downgrade && $x->is_int(); + return $x; } sub blcm { @@ -3930,8 +4256,14 @@ sub blcm { # does not modify arguments, but returns new object # Least Common Multiple - unshift @_, __PACKAGE__ - unless ref($_[0]) || $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i; + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) + { + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; + unshift @_, __PACKAGE__; + } my ($class, @args) = objectify(0, @_); @@ -3944,10 +4276,14 @@ sub blcm { $y = $class -> new($y) unless ref($y) && $y -> isa($class); return $x->bnan() unless $y -> is_int(); my $gcd = $x -> bgcd($y); - $x -> bdiv($gcd) -> bmul($y); + $x = $x -> bdiv($gcd) -> bmul($y); } - return $x -> babs(); + $x = $x -> babs(); + + return $downgrade -> new($x) + if defined $downgrade && $x->is_int(); + return $x; } ############################################################################### @@ -3955,9 +4291,9 @@ sub blcm { ############################################################################### sub length { - my $x = shift; - my $class = ref($x) || $x; - $x = $class->new(shift) unless ref($x); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; return 1 if $LIB->_is_zero($x->{_m}); @@ -3973,7 +4309,13 @@ sub length { sub mantissa { # return a copy of the mantissa - my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + # The following line causes a lot of noise in the test suits for + # the Math-BigRat and bignum distributions. Fixme! + #carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + return $x -> bnan(@r) if $x -> is_nan(); if ($x->{sign} !~ /^[+-]$/) { my $s = $x->{sign}; @@ -3981,14 +4323,19 @@ sub mantissa { return Math::BigInt->new($s, undef, undef); # -inf, +inf => +inf } my $m = Math::BigInt->new($LIB->_str($x->{_m}), undef, undef); - $m->bneg() if $x->{sign} eq '-'; - + $m = $m->bneg() if $x->{sign} eq '-'; $m; } sub exponent { # return a copy of the exponent - my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + # The following line causes a lot of noise in the test suits for + # the Math-BigRat and bignum distributions. Fixme! + #carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + return $x -> bnan(@r) if $x -> is_nan(); if ($x->{sign} !~ /^[+-]$/) { my $s = $x->{sign}; @@ -4000,32 +4347,37 @@ sub exponent { sub parts { # return a copy of both the exponent and the mantissa - my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; if ($x->{sign} !~ /^[+-]$/) { my $s = $x->{sign}; $s =~ s/^\+//; my $se = $s; $se =~ s/^-//; - return ($class->new($s), $class->new($se)); # +inf => inf and -inf, +inf => inf + # +inf => inf and -inf, +inf => inf + return ($class->new($s), $class->new($se)); } my $m = Math::BigInt->bzero(); $m->{value} = $LIB->_copy($x->{_m}); - $m->bneg() if $x->{sign} eq '-'; + $m = $m->bneg() if $x->{sign} eq '-'; ($m, Math::BigInt->new($x->{_es} . $LIB->_num($x->{_e}))); } +# Parts used for scientific notation with significand/mantissa and exponent as +# integers. E.g., "12345.6789" is returned as "123456789" (mantissa) and "-4" +# (exponent). + sub sparts { - my $self = shift; - my $class = ref $self; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - croak("sparts() is an instance method, not a class method") - unless $class; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; # Not-a-number. - if ($self -> is_nan()) { - my $mant = $self -> copy(); # mantissa + if ($x -> is_nan()) { + my $mant = $class -> bnan(); # mantissa return $mant unless wantarray; # scalar context my $expo = $class -> bnan(); # exponent return ($mant, $expo); # list context @@ -4033,8 +4385,8 @@ sub sparts { # Infinity. - if ($self -> is_inf()) { - my $mant = $self -> copy(); # mantissa + if ($x -> is_inf()) { + my $mant = $class -> binf($x->{sign}); # mantissa return $mant unless wantarray; # scalar context my $expo = $class -> binf('+'); # exponent return ($mant, $expo); # list context @@ -4042,56 +4394,46 @@ sub sparts { # Finite number. - my $mant = $class -> bzero(); - $mant -> {sign} = $self -> {sign}; - $mant -> {_m} = $LIB->_copy($self -> {_m}); + my $mant = $x -> copy(); + $mant->{_es} = '+'; + $mant->{_e} = $LIB->_zero(); + $mant = $downgrade -> new($mant) if defined $downgrade; return $mant unless wantarray; - my $expo = $class -> bzero(); - $expo -> {sign} = $self -> {_es}; - $expo -> {_m} = $LIB->_copy($self -> {_e}); - + my $expo = bless { sign => $x -> {_es}, + _m => $LIB->_copy($x -> {_e}), + _es => '+', + _e => $LIB->_zero(), + }, $class; + $expo = $downgrade -> new($expo) if defined $downgrade; return ($mant, $expo); } -sub nparts { - my $self = shift; - my $class = ref $self; +# Parts used for normalized notation with significand/mantissa as either 0 or a +# number in the semi-open interval [1,10). E.g., "12345.6789" is returned as +# "1.23456789" and "4". - croak("nparts() is an instance method, not a class method") - unless $class; +sub nparts { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - # Not-a-number. + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - if ($self -> is_nan()) { - my $mant = $self -> copy(); # mantissa - return $mant unless wantarray; # scalar context - my $expo = $class -> bnan(); # exponent - return ($mant, $expo); # list context - } - - # Infinity. + # Not-a-number and Infinity. - if ($self -> is_inf()) { - my $mant = $self -> copy(); # mantissa - return $mant unless wantarray; # scalar context - my $expo = $class -> binf('+'); # exponent - return ($mant, $expo); # list context - } + return $x -> sparts() if $x -> is_nan() || $x -> is_inf(); # Finite number. - my ($mant, $expo) = $self -> sparts(); + my ($mant, $expo) = $x -> sparts(); if ($mant -> bcmp(0)) { my ($ndigtot, $ndigfrac) = $mant -> length(); my $expo10adj = $ndigtot - $ndigfrac - 1; - if ($expo10adj != 0) { - my $factor = "1e" . -$expo10adj; - $mant -> bmul($factor); + if ($expo10adj > 0) { # if mantissa is not an integer + $mant = $mant -> brsft($expo10adj, 10); return $mant unless wantarray; - $expo -> badd($expo10adj); + $expo = $expo -> badd($expo10adj); return ($mant, $expo); } } @@ -4100,63 +4442,182 @@ sub nparts { return ($mant, $expo); } +# Parts used for engineering notation with significand/mantissa as either 0 or a +# number in the semi-open interval [1,1000) and the exponent is a multiple of 3. +# E.g., "12345.6789" is returned as "12.3456789" and "3". + sub eparts { - my $self = shift; - my $class = ref $self; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - croak("eparts() is an instance method, not a class method") - unless $class; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; # Not-a-number and Infinity. - return $self -> sparts() if $self -> is_nan() || $self -> is_inf(); + return $x -> sparts() if $x -> is_nan() || $x -> is_inf(); # Finite number. - my ($mant, $expo) = $self -> nparts(); + my ($mant, $expo) = $x -> nparts(); my $c = $expo -> copy() -> bmod(3); - $mant -> blsft($c, 10); + $mant = $mant -> blsft($c, 10); return $mant unless wantarray; - $expo -> bsub($c); + $expo = $expo -> bsub($c); return ($mant, $expo); } +# Parts used for decimal notation, e.g., "12345.6789" is returned as "12345" +# (integer part) and "0.6789" (fraction part). + sub dparts { - my $self = shift; - my $class = ref $self; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - croak("dparts() is an instance method, not a class method") - unless $class; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - # Not-a-number and Infinity. + # Not-a-number. + + if ($x -> is_nan()) { + my $int = $class -> bnan(); + return $int unless wantarray; + my $frc = $class -> bzero(); # or NaN? + return ($int, $frc); + } + + # Infinity. - if ($self -> is_nan() || $self -> is_inf()) { - my $int = $self -> copy(); + if ($x -> is_inf()) { + my $int = $class -> binf($x->{sign}); return $int unless wantarray; my $frc = $class -> bzero(); return ($int, $frc); } - my $int = $self -> copy(); - my $frc = $class -> bzero(); + # Finite number. + + my $int = $x -> copy(); + my $frc; + + # If the input is an integer. - # If the input has a fraction part. + if ($int->{_es} eq '+') { + $frc = $class -> bzero(); + } + + # If the input has a fraction part - if ($int->{_es} eq '-') { + else { $int->{_m} = $LIB -> _rsft($int->{_m}, $int->{_e}, 10); $int->{_e} = $LIB -> _zero(); $int->{_es} = '+'; $int->{sign} = '+' if $LIB->_is_zero($int->{_m}); # avoid -0 - return $int unless wantarray; - $frc = $self -> copy() -> bsub($int); + $frc = $x -> copy() -> bsub($int); return ($int, $frc); } + $int = $downgrade -> new($int) if defined $downgrade; return $int unless wantarray; - return ($int, $frc); + return $int, $frc; +} + +# Fractional parts with the numerator and denominator as integers. E.g., +# "123.4375" is returned as "1975" and "16". + +sub fparts { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # NaN => NaN/NaN + + if ($x -> is_nan()) { + return $class -> bnan() unless wantarray; + return $class -> bnan(), $class -> bnan(); + } + + # ±Inf => ±Inf/1 + + if ($x -> is_inf()) { + my $numer = $class -> binf($x->{sign}); + return $numer unless wantarray; + my $denom = $class -> bone(); + return $numer, $denom; + } + + # Finite number. + + # If we get here, we know that the output is an integer. + + $class = $downgrade if defined $downgrade; + + my @flt_parts = ($x->{sign}, $x->{_m}, $x->{_es}, $x->{_e}); + my @rat_parts = $class -> _flt_lib_parts_to_rat_lib_parts(@flt_parts); + my $num = $class -> new($LIB -> _str($rat_parts[1])); + my $den = $class -> new($LIB -> _str($rat_parts[2])); + $num = $num -> bneg() if $rat_parts[0] eq "-"; + return $num unless wantarray; + return $num, $den; +} + +# Given "123.4375", returns "1975", since "123.4375" is "1975/16". + +sub numerator { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + return $class -> bnan() if $x -> is_nan(); + return $class -> binf($x -> sign()) if $x -> is_inf(); + return $class -> bzero() if $x -> is_zero(); + + # If we get here, we know that the output is an integer. + + $class = $downgrade if defined $downgrade; + + if ($x -> {_es} eq '-') { # exponent < 0 + my $numer_lib = $LIB -> _copy($x -> {_m}); + my $denom_lib = $LIB -> _1ex($x -> {_e}); + my $gcd_lib = $LIB -> _gcd($LIB -> _copy($numer_lib), $denom_lib); + $numer_lib = $LIB -> _div($numer_lib, $gcd_lib); + return $class -> new($x -> {sign} . $LIB -> _str($numer_lib)); + } + + elsif (! $LIB -> _is_zero($x -> {_e})) { # exponent > 0 + my $numer_lib = $LIB -> _copy($x -> {_m}); + $numer_lib = $LIB -> _lsft($numer_lib, $x -> {_e}, 10); + return $class -> new($x -> {sign} . $LIB -> _str($numer_lib)); + } + + else { # exponent = 0 + return $class -> new($x -> {sign} . $LIB -> _str($x -> {_m})); + } +} + +# Given "123.4375", returns "16", since "123.4375" is "1975/16". + +sub denominator { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + return $class -> bnan() if $x -> is_nan(); + + # If we get here, we know that the output is an integer. + + $class = $downgrade if defined $downgrade; + + if ($x -> {_es} eq '-') { # exponent < 0 + my $numer_lib = $LIB -> _copy($x -> {_m}); + my $denom_lib = $LIB -> _1ex($x -> {_e}); + my $gcd_lib = $LIB -> _gcd($LIB -> _copy($numer_lib), $denom_lib); + $denom_lib = $LIB -> _div($denom_lib, $gcd_lib); + return $class -> new($LIB -> _str($denom_lib)); + } + + else { # exponent >= 0 + return $class -> bone(); + } } ############################################################################### @@ -4167,13 +4628,19 @@ sub bstr { # (ref to BFLOAT or num_str) return num_str # Convert number from internal format to (non-scientific) string format. # internal format is always normalized (no leading zeros, "-0" => "+0") - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - if ($x->{sign} !~ /^[+-]$/) { - return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN - return 'inf'; # +inf + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN + + if ($x->{sign} ne '+' && $x->{sign} ne '-') { + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf } + # Finite number + my $es = '0'; my $len = 1; my $cad = 0; @@ -4221,91 +4688,243 @@ sub bstr { $es; } -# Decimal notation, e.g., "12345.6789". +# Decimal notation, e.g., "12345.6789" (no exponent). sub bdstr { - my $x = shift; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN if ($x->{sign} ne '+' && $x->{sign} ne '-') { - return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN - return 'inf'; # +inf + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf } + # Upgrade? + + return $upgrade -> bdstr($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number + my $mant = $LIB->_str($x->{_m}); - my $expo = $x -> exponent(); + my $esgn = $x->{_es}; + my $eabs = $LIB -> _num($x->{_e}); + + my $uintmax = ~0; my $str = $mant; - if ($expo >= 0) { - $str .= "0" x $expo; + if ($esgn eq '+') { + + croak("The absolute value of the exponent is too large") + if $eabs > $uintmax; + + $str .= "0" x $eabs; + } else { - my $mantlen = CORE::length($mant); - my $c = $mantlen + $expo; + my $mlen = CORE::length($mant); + my $c = $mlen - $eabs; + + my $intmax = ($uintmax - 1) / 2; + croak("The absolute value of the exponent is too large") + if (1 - $c) > $intmax; + $str = "0" x (1 - $c) . $str if $c <= 0; - substr($str, $expo, 0) = '.'; + substr($str, -$eabs, 0) = '.'; } - return $x->{sign} eq '-' ? "-$str" : $str; + return $x->{sign} eq '-' ? '-' . $str : $str; } -# Scientific notation with significand/mantissa as an integer, e.g., "12345.6789" -# is written as "123456789e-4". +# Scientific notation with significand/mantissa and exponent as integers, e.g., +# "12345.6789" is written as "123456789e-4". sub bsstr { - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN if ($x->{sign} ne '+' && $x->{sign} ne '-') { - return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN - return 'inf'; # +inf + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf } - my $str = $LIB->_str($x->{_m}) . 'e' . $x->{_es}. $LIB->_str($x->{_e}); - return $x->{sign} eq '-' ? "-$str" : $str; + # Upgrade? + + return $upgrade -> bsstr($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number + + ($x->{sign} eq '-' ? '-' : '') . $LIB->_str($x->{_m}) + . 'e' . $x->{_es} . $LIB->_str($x->{_e}); } # Normalized notation, e.g., "12345.6789" is written as "1.23456789e+4". sub bnstr { - my $x = shift; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN if ($x->{sign} ne '+' && $x->{sign} ne '-') { - return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN - return 'inf'; # +inf + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf } - my ($mant, $expo) = $x -> nparts(); + # Upgrade? + + return $upgrade -> bnstr($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number - my $esgn = $expo < 0 ? '-' : '+'; - my $eabs = $expo -> babs() -> bfround(0) -> bstr(); - #$eabs = '0' . $eabs if length($eabs) < 2; + my $str = $x->{sign} eq '-' ? '-' : ''; - return $mant . 'e' . $esgn . $eabs; + # Get the mantissa and the length of the mantissa. + + my $mant = $LIB->_str($x->{_m}); + my $mantlen = CORE::length($mant); + + if ($mantlen == 1) { + + # Not decimal point when the mantissa has length one, i.e., return the + # number 2 as the string "2", not "2.". + + $str .= $mant . 'e' . $x->{_es} . $LIB->_str($x->{_e}); + + } else { + + # Compute new exponent where the original exponent is adjusted by the + # length of the mantissa minus one (because the decimal point is after + # one digit). + + my ($eabs, $esgn) = $LIB -> _sadd($LIB -> _copy($x->{_e}), $x->{_es}, + $LIB -> _new($mantlen - 1), "+"); + substr $mant, 1, 0, "."; + $str .= $mant . 'e' . $esgn . $LIB->_str($eabs); + + } + + return $str; } # Engineering notation, e.g., "12345.6789" is written as "12.3456789e+3". sub bestr { - my $x = shift; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN if ($x->{sign} ne '+' && $x->{sign} ne '-') { - return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN - return 'inf'; # +inf + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf + } + + # Upgrade? + + return $upgrade -> bestr($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number + + my $str = $x->{sign} eq '-' ? '-' : ''; + + # Get the mantissa, the length of the mantissa, and adjust the exponent by + # the length of the mantissa minus 1 (because the dot is after one digit). + + my $mant = $LIB->_str($x->{_m}); + my $mantlen = CORE::length($mant); + my ($eabs, $esgn) = $LIB -> _sadd($LIB -> _copy($x->{_e}), $x->{_es}, + $LIB -> _new($mantlen - 1), "+"); + + my $dotpos = 1; + my $mod = $LIB -> _mod($LIB -> _copy($eabs), $LIB -> _new("3")); + unless ($LIB -> _is_zero($mod)) { + if ($esgn eq '+') { + $eabs = $LIB -> _sub($eabs, $mod); + $dotpos += $LIB -> _num($mod); + } else { + my $delta = $LIB -> _sub($LIB -> _new("3"), $mod); + $eabs = $LIB -> _add($eabs, $delta); + $dotpos += $LIB -> _num($delta); + } } - my ($mant, $expo) = $x -> eparts(); + if ($dotpos < $mantlen) { + substr $mant, $dotpos, 0, "."; + } elsif ($dotpos > $mantlen) { + $mant .= "0" x ($dotpos - $mantlen); + } - my $esgn = $expo < 0 ? '-' : '+'; - my $eabs = $expo -> babs() -> bfround(0) -> bstr(); - #$eabs = '0' . $eabs if length($eabs) < 2; + $str .= $mant . 'e' . $esgn . $LIB->_str($eabs); - return $mant . 'e' . $esgn . $eabs; + return $str; +} + +# Fractional notation, e.g., "123.4375" is written as "1975/16". + +sub bfstr { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN + + if ($x->{sign} ne '+' && $x->{sign} ne '-') { + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf + } + + # Upgrade? + + return $upgrade -> bfstr($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number + + my $str = $x->{sign} eq '-' ? '-' : ''; + + if ($x->{_es} eq '+') { + $str .= $LIB -> _str($x->{_m}) . ("0" x $LIB -> _num($x->{_e})); + } else { + my @flt_parts = ($x->{sign}, $x->{_m}, $x->{_es}, $x->{_e}); + my @rat_parts = $class -> _flt_lib_parts_to_rat_lib_parts(@flt_parts); + $str = $LIB -> _str($rat_parts[1]) . "/" . $LIB -> _str($rat_parts[2]); + $str = "-" . $str if $rat_parts[0] eq "-"; + } + + return $str; } sub to_hex { # return number as hexadecimal string (only for integers defined) + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); - my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN + + if ($x->{sign} ne '+' && $x->{sign} ne '-') { + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf + } + + # Upgrade? + + return $upgrade -> to_hex($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number - return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc return '0' if $x->is_zero(); return $nan if $x->{_es} ne '+'; # how to do 1e-1 in hex? @@ -4320,10 +4939,24 @@ sub to_hex { sub to_oct { # return number as octal digit string (only for integers defined) + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); - my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN + + if ($x->{sign} ne '+' && $x->{sign} ne '-') { + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf + } + + # Upgrade? + + return $upgrade -> to_hex($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number - return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc return '0' if $x->is_zero(); return $nan if $x->{_es} ne '+'; # how to do 1e-1 in octal? @@ -4338,10 +4971,24 @@ sub to_oct { sub to_bin { # return number as binary digit string (only for integers defined) + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); - my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN + + if ($x->{sign} ne '+' && $x->{sign} ne '-') { + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf + } + + # Upgrade? + + return $upgrade -> to_hex($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number - return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc return '0' if $x->is_zero(); return $nan if $x->{_es} ne '+'; # how to do 1e-1 in binary? @@ -4355,9 +5002,9 @@ sub to_bin { } sub to_ieee754 { - my $x = shift; - my $format = shift; - my $class = ref $x; + my ($class, $x, $format, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; my $enc; # significand encoding (applies only to decimal) my $k; # storage width in bits @@ -4494,41 +5141,85 @@ sub to_ieee754 { $expo = $class -> new($expo_est); if ($expo_est > 0) { - $mant -> bmul($binv -> copy() -> bpow($expo)); + $mant = $mant -> bmul($binv -> copy() -> bpow($expo)); } elsif ($expo_est < 0) { my $expo_abs = $expo -> copy() -> bneg(); - $mant -> bmul($b -> copy() -> bpow($expo_abs)); + $mant = $mant -> bmul($b -> copy() -> bpow($expo_abs)); } - # Final adjustment. + # Final adjustment of the estimate above. while ($mant >= $b && $expo <= $emax) { - $mant -> bmul($binv); - $expo -> binc(); + $mant = $mant -> bmul($binv); + $expo = $expo -> binc(); } while ($mant < $one && $expo >= $emin) { - $mant -> bmul($b); - $expo -> bdec(); + $mant = $mant -> bmul($b); + $expo = $expo -> bdec(); } - # Encode as infinity, normal number or subnormal number? + # This is when the magnitude is larger than what can be represented + # in this format. Encode as infinity. - if ($expo > $emax) { # overflow => infinity - $expo = $emax -> copy() -> binc(); + if ($expo > $emax) { $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 = $emax -> copy() -> binc(); + } + + # This is when the magnitude is so small that the number is encoded + # as a subnormal number. + # + # If the magnitude is smaller than that of the smallest subnormal + # number, and rounded downwards, it is encoded as zero. This works + # transparently and does not need to be treated as a special case. + # + # If the number is between the largest subnormal number and the + # smallest normal number, and the value is rounded upwards, the + # value must be encoded as a normal number. This must be treated as + # a special case. + + elsif ($expo < $emin) { + + # Scale up the mantissa (significand), and round to integer. + + my $const = $class -> new($b) -> bpow($t - 1); + $mant = $mant -> bmul($const); + $mant = $mant -> bfround(0); + + # If the mantissa overflowed, encode as the smallest normal + # number. + + if ($mant == $const -> bmul($b)) { + $mant = $mant -> bzero(); + $expo = $expo -> binc(); + } + } + + # This is when the magnitude is within the range of what can be + # encoded as a normal number. + + else { + + # Remove implicit leading bit, scale up the mantissa + # (significand) to an integer, and round. + + $mant = $mant -> bdec(); + my $const = $class -> new($b) -> bpow($t); + $mant = $mant -> bmul($const) -> bfround(0); + + # If the mantissa overflowed, encode as the next larger value. + # This works correctly also when the next larger value is + # infinity. + + if ($mant == $const) { + $mant = $mant -> bzero(); + $expo = $expo -> binc(); + } } } - $expo -> badd($bias); # add bias + $expo = $expo -> badd($bias); # add bias my $signbit = "$sign"; @@ -4548,7 +5239,9 @@ sub to_ieee754 { sub as_hex { # return number as hexadecimal string (only for integers defined) - my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + my (undef, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc return '0x0' if $x->is_zero(); @@ -4566,7 +5259,9 @@ sub as_hex { sub as_oct { # return number as octal digit string (only for integers defined) - my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + my (undef, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc return '00' if $x->is_zero(); @@ -4584,7 +5279,9 @@ sub as_oct { sub as_bin { # return number as binary digit string (only for integers defined) - my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + my (undef, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc return '0b0' if $x->is_zero(); @@ -4601,21 +5298,25 @@ sub as_bin { sub numify { # Make a Perl scalar number from a Math::BigFloat object. - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + + my (undef, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; if ($x -> is_nan()) { require Math::Complex; - my $inf = Math::Complex::Inf(); + my $inf = $Math::Complex::Inf; return $inf - $inf; } if ($x -> is_inf()) { require Math::Complex; - my $inf = Math::Complex::Inf(); + my $inf = $Math::Complex::Inf; return $x -> is_negative() ? -$inf : $inf; } # Create a string and let Perl's atoi()/atof() handle the rest. + return 0 + $x -> bnstr(); } @@ -4625,65 +5326,97 @@ sub numify { sub import { my $class = shift; - my $l = scalar @_; - my $lib = ''; - my @a; - my $lib_kind = 'try'; - $IMPORT=1; - for (my $i = 0; $i < $l ; $i++) { - if ($_[$i] eq ':constant') { - # This causes overlord er load to step in. 'binary' and 'integer' - # are handled by BigInt. - overload::constant float => sub { $class->new(shift); }; - } elsif ($_[$i] eq 'upgrade') { - # this causes upgrading - $upgrade = $_[$i+1]; # or undef to disable - $i++; - } elsif ($_[$i] eq 'downgrade') { - # this causes downgrading - $downgrade = $_[$i+1]; # or undef to disable - $i++; - } elsif ($_[$i] =~ /^(lib|try|only)\z/) { - # alternative library - $lib = $_[$i+1] || ''; # default Calc - $lib_kind = $1; # lib, try or only - $i++; - } elsif ($_[$i] eq 'with') { + $IMPORT++; # remember we did import() + + my @import = ('objectify'); + my @a; # unrecognized arguments + + while (@_) { + my $param = shift; + + # Enable overloading of constants. + + if ($param eq ':constant') { + overload::constant + + integer => sub { + $class -> new(shift); + }, + + float => sub { + $class -> new(shift); + }, + + binary => sub { + # E.g., a literal 0377 shall result in an object whose value + # is decimal 255, but new("0377") returns decimal 377. + return $class -> from_oct($_[0]) if $_[0] =~ /^0_*[0-7]/; + $class -> new(shift); + }; + next; + } + + # Upgrading. + + if ($param eq 'upgrade') { + $class -> upgrade(shift); + next; + } + + # Downgrading. + + if ($param eq 'downgrade') { + $class -> downgrade(shift); + next; + } + + # Accuracy. + + if ($param eq 'accuracy') { + $class -> accuracy(shift); + next; + } + + # Precision. + + if ($param eq 'precision') { + $class -> precision(shift); + next; + } + + # Rounding mode. + + if ($param eq 'round_mode') { + $class -> round_mode(shift); + next; + } + + # Backend library. + + if ($param =~ /^(lib|try|only)\z/) { + push @import, $param; + push @import, shift() if @_; + next; + } + + if ($param eq 'with') { # alternative class for our private parts() # XXX: no longer supported - # $LIB = $_[$i+1] || 'Math::BigInt'; - $i++; - } else { - push @a, $_[$i]; + # $LIB = shift() || 'Calc'; + # carp "'with' is no longer supported, use 'lib', 'try', or 'only'"; + shift; + next; } - } - - $lib =~ tr/a-zA-Z0-9,://cd; # restrict to sane characters - # let use Math::BigInt lib => 'GMP'; use Math::BigFloat; still work - my $mbilib = eval { Math::BigInt->config('lib') }; - if ((defined $mbilib) && ($LIB eq 'Math::BigInt::Calc')) { - # $LIB already loaded - Math::BigInt->import($lib_kind, "$lib, $mbilib", 'objectify'); - } else { - # $LIB not loaded, or with ne "Math::BigInt::Calc" - $lib .= ",$mbilib" if defined $mbilib; - $lib =~ s/^,//; # don't leave empty - # replacement library can handle lib statement, but also could ignore it + # Unrecognized parameter. - # Perl < 5.6.0 dies with "out of memory!" when eval() and ':constant' is - # used in the same script, or eval inside import(). So we require MBI: - require Math::BigInt; - Math::BigInt->import($lib_kind => $lib, 'objectify'); + push @a, $param; } - if ($@) { - croak("Couldn't load $lib: $! $@"); - } - # find out which one was actually loaded - $LIB = Math::BigInt->config('lib'); - # register us with MBI to get notified of future lib changes - Math::BigInt::_register_callback($class, sub { $LIB = $_[0]; }); + Math::BigInt -> import(@import); + + # find out which one was actually loaded + $LIB = Math::BigInt -> config('lib'); $class->export_to_level(1, $class, @a); # export wanted functions } @@ -4701,17 +5434,20 @@ sub _len_to_steps { my $l = 40; my $r = $d; - # Otherwise this does not work under -Mbignum and we do not yet have "no bignum;" :( + # Otherwise this does not work under -Mbignum and we do not yet have "no + # bignum;" :( $l = $l->numify if ref($l); $r = $r->numify if ref($r); $lg2 = $lg2->numify if ref($lg2); $lg10 = $lg10->numify if ref($lg10); - # binary search for the right value (could this be written as the reverse of lg(n!)?) + # binary search for the right value (could this be written as the reverse of + # lg(n!)?) while ($r - $l > 1) { my $n = int(($r - $l) / 2) + $l; - my $ramanujan = - int(($n * log($n) - $n + log($n * (1 + 4*$n*(1+2*$n))) / 6 + $lg2) / $lg10); + my $ramanujan + = int(($n * log($n) - $n + log($n * (1 + 4*$n*(1+2*$n))) / 6 + $lg2) + / $lg10); $ramanujan > $d ? $r = $n : $l = $n; } $l; @@ -4745,15 +5481,19 @@ sub _log { my ($limit, $v, $u, $below, $factor, $next, $over, $f); - $v = $x->copy(); $v->binc(); # v = x+1 - $x->bdec(); $u = $x->copy(); # u = x-1; x = x-1 - $x->bdiv($v, $scale); # first term: u/v + $v = $x->copy(); + $v = $v -> binc(); # v = x+1 + $x = $x->bdec(); + $u = $x->copy(); # u = x-1; x = x-1 + $x = $x->bdiv($v, $scale); # first term: u/v $below = $v->copy(); $over = $u->copy(); - $u *= $u; $v *= $v; # u^2, v^2 - $below->bmul($v); # u^3, v^3 - $over->bmul($u); - $factor = $class->new(3); $f = $class->new(2); + $u = $u -> bmul($u); # u^2 + $v = $v -> bmul($v); # v^2 + $below = $below->bmul($v); # u^3, v^3 + $over = $over->bmul($u); + $factor = $class->new(3); + $f = $class->new(2); $limit = $class->new("1E-". ($scale-1)); @@ -4769,27 +5509,24 @@ sub _log { # round $over and $below first, we save a lot of time for the division # (not with log(1.2345), but try log (123**123) to see what I mean. This # can introduce a rounding error if the division result would be f.i. - # 0.1234500000001 and we round it to 5 digits it would become 0.12346, but - # if we truncated $over and $below we might get 0.12345. Does this matter - # for the end result? So we give $over and $below 4 more digits to be - # on the safe side (unscientific error handling as usual... :+D + # 0.1234500000001 and we round it to 5 digits it would become 0.12346, + # but if we truncated $over and $below we might get 0.12345. Does this + # matter for the end result? So we give $over and $below 4 more digits + # to be on the safe side (unscientific error handling as usual... :+D $next = $over->copy()->bround($scale+4) ->bdiv($below->copy()->bmul($factor)->bround($scale+4), $scale); - ## old version: - ## $next = $over->copy()->bdiv($below->copy()->bmul($factor), $scale); - last if $next->bacmp($limit) <= 0; delete $next->{_a}; delete $next->{_p}; - $x->badd($next); + $x = $x->badd($next); # calculate things for the next term $over *= $u; $below *= $v; - $factor->badd($f); + $factor = $factor->badd($f); } $x->bmul($f); # $x *= 2 } @@ -4808,9 +5545,9 @@ sub _log_10 { # long, we make it faster by about a factor of 100 by dividing $x by 10. # The same observation is valid for numbers smaller than 0.1, e.g. computing - # log(1) is fastest, and the further away we get from 1, the longer it takes. - # So we also 'break' this down by multiplying $x with 10 and subtract the - # log(10) afterwards to get the correct result. + # log(1) is fastest, and the further away we get from 1, the longer it + # takes. So we also 'break' this down by multiplying $x with 10 and subtract + # the log(10) afterwards to get the correct result. # To get $x even closer to 1, we also divide by 2 and then use log(2) to # correct for this. For instance if $x is 2.4, we use the formula: @@ -4841,8 +5578,8 @@ sub _log_10 { $dbd = 0; # disable shortcut # we can use the cached value in these cases if ($scale <= $LOG_10_A) { - $x->bzero(); - $x->badd($LOG_10); # modify $x in place + $x = $x->bzero(); + $x = $x->badd($LOG_10); # modify $x in place $calc = 0; # no need to calc, but round } # if we can't use the shortcut, we continue normally @@ -4854,8 +5591,8 @@ sub _log_10 { $dbd = 0; # disable shortcut # we can use the cached value in these cases if ($scale <= $LOG_2_A) { - $x->bzero(); - $x->badd($LOG_2); # modify $x in place + $x = $x->bzero(); + $x = $x->badd($LOG_2); # modify $x in place $calc = 0; # no need to calc, but round } # if we can't use the shortcut, we continue normally @@ -4871,8 +5608,8 @@ sub _log_10 { $dbd = 0; # disable shortcut # we can use the cached value in these cases if ($scale <= $LOG_10_A) { - $x->bzero(); - $x->bsub($LOG_10); + $x = $x->bzero(); + $x = $x->bsub($LOG_10); $calc = 0; # no need to calc, but round } } @@ -4893,8 +5630,8 @@ sub _log_10 { $LOG_10 = $class->new($LOG_10, undef, undef) unless ref $LOG_10; #print "x = $x, dbd = $dbd, calc = $calc\n"; - # got more than one digit before the dot, or more than one zero after the - # dot, so do: + # got more than one digit before the dot, or more than one zero after + # the dot, so do: # log(123) == log(1.23) + log(10) * 2 # log(0.0123) == log(1.23) - log(10) * 2 @@ -4903,7 +5640,12 @@ sub _log_10 { $l_10 = $LOG_10->copy(); # copy for mul } else { # else: slower, compute and cache result - # also disable downgrade for this code path + + # Disabling upgrading and downgrading is no longer necessary to + # avoid an infinite recursion, but it avoids unnecessary upgrading + # and downgrading in the intermediate computations. + + local $Math::BigInt::upgrade = undef; local $Math::BigFloat::downgrade = undef; # shorten the time to calculate log(10) based on the following: @@ -4918,7 +5660,7 @@ sub _log_10 { } else { # else: slower, compute and cache result $l_2 = $two->copy(); - $l_2->_log($scale); # scale+4, actually + $l_2 = $l_2->_log($scale); # scale+4, actually $LOG_2 = $l_2->copy(); # cache the result for later # the copy() is for mul below $LOG_2_A = $scale; @@ -4926,26 +5668,25 @@ sub _log_10 { # now calculate log(1.25): $l_10 = $class->new('1.25'); - $l_10->_log($scale); # scale+4, actually + $l_10 = $l_10->_log($scale); # scale+4, actually # log(1.25) + log(2) + log(2) + log(2): - $l_10->badd($l_2); - $l_10->badd($l_2); - $l_10->badd($l_2); + $l_10 = $l_10->badd($l_2); + $l_10 = $l_10->badd($l_2); + $l_10 = $l_10->badd($l_2); $LOG_10 = $l_10->copy(); # cache the result for later # the copy() is for mul below $LOG_10_A = $scale; } $dbd-- if ($dbd > 1); # 20 => dbd=2, so make it dbd=1 - $l_10->bmul($class->new($dbd)); # log(10) * (digits_before_dot-1) + $l_10 = $l_10->bmul($class->new($dbd)); # log(10) * (digits_before_dot-1) my $dbd_sign = '+'; if ($dbd < 0) { $dbd = -$dbd; $dbd_sign = '-'; } ($x->{_e}, $x->{_es}) = - _e_sub($x->{_e}, $LIB->_new($dbd), $x->{_es}, $dbd_sign); # 123 => 1.23 - + $LIB -> _ssub($x->{_e}, $x->{_es}, $LIB->_new($dbd), $dbd_sign); } # Now: 0.1 <= $x < 10 (and possible correction in l_10) @@ -4958,13 +5699,13 @@ sub _log_10 { my $twos = 0; # default: none (0 times) while ($x->bacmp($HALF) <= 0) { # X <= 0.5 $twos--; - $x->bmul($two); + $x = $x->bmul($two); } while ($x->bacmp($two) >= 0) { # X >= 2 $twos++; - $x->bdiv($two, $scale+4); # keep all digits + $x = $x->bdiv($two, $scale+4); # keep all digits } - $x->bround($scale+4); + $x = $x->bround($scale+4); # $twos > 0 => did mul 2, < 0 => did div 2 (but we never did both) # So calculate correction factor based on ln(2): if ($twos != 0) { @@ -4974,69 +5715,33 @@ sub _log_10 { $l_2 = $LOG_2->copy(); # copy() for the mul below } else { # else: slower, compute and cache result - # also disable downgrade for this code path + + # Disabling upgrading and downgrading is no longer necessary to + # avoid an infinite recursion, but it avoids unnecessary upgrading + # and downgrading in the intermediate computations. + + local $Math::BigInt::upgrade = undef; local $Math::BigFloat::downgrade = undef; + $l_2 = $two->copy(); - $l_2->_log($scale); # scale+4, actually + $l_2 = $l_2->_log($scale); # scale+4, actually $LOG_2 = $l_2->copy(); # cache the result for later # the copy() is for mul below $LOG_2_A = $scale; } - $l_2->bmul($twos); # * -2 => subtract, * 2 => add + $l_2 = $l_2->bmul($twos); # * -2 => subtract, * 2 => add } else { undef $l_2; } - $x->_log($scale); # need to do the "normal" way - $x->badd($l_10) if defined $l_10; # correct it by ln(10) - $x->badd($l_2) if defined $l_2; # and maybe by ln(2) + $x = $x->_log($scale); # need to do the "normal" way + $x = $x->badd($l_10) if defined $l_10; # correct it by ln(10) + $x = $x->badd($l_2) if defined $l_2; # and maybe by ln(2) # all done, $x contains now the result $x; } -sub _e_add { - # Internal helper sub to take two positive integers and their signs and - # then add them. Input ($LIB, $LIB, ('+'|'-'), ('+'|'-')), output - # ($LIB, ('+'|'-')). - - my ($x, $y, $xs, $ys) = @_; - - # if the signs are equal we can add them (-5 + -3 => -(5 + 3) => -8) - if ($xs eq $ys) { - $x = $LIB->_add($x, $y); # +a + +b or -a + -b - } else { - my $a = $LIB->_acmp($x, $y); - if ($a == 0) { - # This does NOT modify $x in-place. TODO: Fix this? - $x = $LIB->_zero(); # result is 0 - $xs = '+'; - return ($x, $xs); - } - if ($a > 0) { - $x = $LIB->_sub($x, $y); # abs sub - } else { # a < 0 - $x = $LIB->_sub ($y, $x, 1); # abs sub - $xs = $ys; - } - } - - $xs = '+' if $xs eq '-' && $LIB->_is_zero($x); # no "-0" - - return ($x, $xs); -} - -sub _e_sub { - # Internal helper sub to take two positive integers and their signs and - # then subtract them. Input ($LIB, $LIB, ('+'|'-'), ('+'|'-')), - # output ($LIB, ('+'|'-')) - my ($x, $y, $xs, $ys) = @_; - - # flip sign - $ys = $ys eq '+' ? '-' : '+'; # swap sign of second operand ... - _e_add($x, $y, $xs, $ys); # ... and let _e_add() do the job -} - sub _pow { # Calculate a power where $y is a non-integer, like 2 ** 0.3 my ($x, $y, @r) = @_; @@ -5079,23 +5784,32 @@ sub _pow { # when user set globals, they would interfere with our calculation, so # disable them and later re-enable them no strict 'refs'; - my $abr = "$class\::accuracy"; my $ab = $$abr; $$abr = undef; - my $pbr = "$class\::precision"; my $pb = $$pbr; $$pbr = undef; + my $abr = "$class\::accuracy"; + my $ab = $$abr; + $$abr = undef; + my $pbr = "$class\::precision"; + my $pb = $$pbr; + $$pbr = undef; # we also need to disable any set A or P on $x (_find_round_parameters took # them already into account), since these would interfere, too delete $x->{_a}; delete $x->{_p}; - # need to disable $upgrade in BigInt, to avoid deep recursion + + # Disabling upgrading and downgrading is no longer necessary to avoid an + # infinite recursion, but it avoids unnecessary upgrading and downgrading in + # the intermediate computations. + local $Math::BigInt::upgrade = undef; + local $Math::BigFloat::downgrade = undef; my ($limit, $v, $u, $below, $factor, $next, $over); $u = $x->copy()->blog(undef, $scale)->bmul($y); my $do_invert = ($u->{sign} eq '-'); - $u->bneg() if $do_invert; + $u = $u->bneg() if $do_invert; $v = $class->bone(); # 1 $factor = $class->new(2); # 2 - $x->bone(); # first term: 1 + $x = $x->bone(); # first term: 1 $below = $v->copy(); $over = $u->copy(); @@ -5107,25 +5821,25 @@ sub _pow { # anymore, so we stop: $next = $over->copy()->bdiv($below, $scale); last if $next->bacmp($limit) <= 0; - $x->badd($next); + $x = $x->badd($next); # calculate things for the next term $over *= $u; $below *= $factor; - $factor->binc(); + $factor = $factor->binc(); last if $x->{sign} !~ /^[-+]$/; } if ($do_invert) { my $x_copy = $x->copy(); - $x->bone->bdiv($x_copy, $scale); + $x = $x->bone->bdiv($x_copy, $scale); } # shortcut to not run through _find_round_parameters again if (defined $params[0]) { - $x->bround($params[0], $params[2]); # then round accordingly + $x = $x->bround($params[0], $params[2]); # then round accordingly } else { - $x->bfround($params[1], $params[2]); # then round accordingly + $x = $x->bfround($params[1], $params[2]); # then round accordingly } if ($fallback) { # clear a/p after round, since user did not request it @@ -5138,6 +5852,19 @@ sub _pow { $x; } +# These functions are only provided for backwards compabibility so that old +# version of Math::BigRat etc. don't complain about missing them. + +sub _e_add { + my ($x, $y, $xs, $ys) = @_; + return $LIB -> _sadd($x, $xs, $y, $ys); +} + +sub _e_sub { + my ($x, $y, $xs, $ys) = @_; + return $LIB -> _ssub($x, $xs, $y, $ys); +} + 1; __END__ @@ -5146,7 +5873,7 @@ __END__ =head1 NAME -Math::BigFloat - Arbitrary size floating point math package +Math::BigFloat - arbitrary size floating point math package =head1 SYNOPSIS @@ -5169,10 +5896,13 @@ Math::BigFloat - Arbitrary size floating point math package $x = Math::BigFloat->new($str); # defaults to 0 $x = Math::BigFloat->new('0x123'); # from hexadecimal + $x = Math::BigFloat->new('0o377'); # from octal $x = Math::BigFloat->new('0b101'); # from binary $x = Math::BigFloat->from_hex('0xc.afep+3'); # from hex $x = Math::BigFloat->from_hex('cafe'); # ditto $x = Math::BigFloat->from_oct('1.3267p-4'); # from octal + $x = Math::BigFloat->from_oct('01.3267p-4'); # ditto + $x = Math::BigFloat->from_oct('0o1.3267p-4'); # ditto $x = Math::BigFloat->from_oct('0377'); # ditto $x = Math::BigFloat->from_bin('0b1.1001p-4'); # from binary $x = Math::BigFloat->from_bin('0101'); # ditto @@ -5187,6 +5917,8 @@ Math::BigFloat - Arbitrary size floating point math package $y = $x->copy(); # make a copy (unlike $y = $x) $y = $x->as_int(); # return as BigInt + $y = $x->as_float(); # return as a Math::BigFloat + $y = $x->as_rat(); # return as a Math::BigRat # Boolean methods (these don't modify the invocand) @@ -5297,6 +6029,9 @@ Math::BigFloat - Arbitrary size floating point math package $x->nparts(); # mantissa and exponent (normalised) $x->eparts(); # mantissa and exponent (engineering notation) $x->dparts(); # integer and fraction part + $x->fparts(); # numerator and denominator + $x->numerator(); # numerator + $x->denominator(); # denominator # Conversion methods (do not modify the invocand) @@ -5305,6 +6040,8 @@ Math::BigFloat - Arbitrary size floating point math package $x->bnstr(); # string in normalized notation $x->bestr(); # string in engineering notation $x->bdstr(); # string in decimal notation + $x->bfstr(); # string in fractional notation + $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 @@ -5330,7 +6067,8 @@ exactly what you expect. =head2 Input Input values to these routines may be any scalar number or string that looks -like a number and represents a floating point number. +like a number. Anything that is accepted by Perl as a literal numeric constant +should be accepted by this module. =over @@ -5340,48 +6078,77 @@ Leading and trailing whitespace is ignored. =item * -Leading and trailing zeros are ignored. +Leading zeros are ignored, except for floating point numbers with a binary +exponent, in which case the number is interpreted as an octal floating point +number. For example, "01.4p+0" gives 1.5, "00.4p+0" gives 0.5, but "0.4p+0" +gives a NaN. And while "0377" gives 255, "0377p0" gives 255. =item * -If the string has a "0x" prefix, it is interpreted as a hexadecimal number. +If the string has a "0x" or "0X" prefix, it is interpreted as a hexadecimal +number. =item * -If the string has a "0b" prefix, it is interpreted as a binary number. +If the string has a "0o" or "0O" prefix, it is interpreted as an octal number. A +floating point literal with a "0" prefix is also interpreted as an octal number. =item * -For hexadecimal and binary numbers, the exponent must be separated from the -significand (mantissa) by the letter "p" or "P", not "e" or "E" as with decimal -numbers. +If the string has a "0b" or "0B" prefix, it is interpreted as a binary number. =item * -One underline is allowed between any two digits, including hexadecimal and -binary digits. +Underline characters are allowed in the same way as they are allowed in literal +numerical constants. =item * If the string can not be interpreted, NaN is returned. -=back +=item * + +For hexadecimal, octal, and binary floating point numbers, the exponent must be +separated from the significand (mantissa) by the letter "p" or "P", not "e" or +"E" as with decimal numbers. -Octal numbers are typically prefixed by "0", but since leading zeros are -stripped, these methods can not automatically recognize octal numbers, so use -the constructor from_oct() to interpret octal strings. +=back Some examples of valid string input Input string Resulting value + 123 123 1.23e2 123 12300e-2 123 - 0xcafe 51966 - 0b1101 13 + 67_538_754 67538754 -4_5_6.7_8_9e+0_1_0 -4567890000000 + + 0x13a 314 + 0x13ap0 314 + 0x1.3ap+8 314 + 0x0.00013ap+24 314 + 0x13a000p-12 314 + + 0o472 314 + 0o1.164p+8 314 + 0o0.0001164p+20 314 + 0o1164000p-10 314 + + 0472 472 Note! + 01.164p+8 314 + 00.0001164p+20 314 + 01164000p-10 314 + + 0b100111010 314 + 0b1.0011101p+8 314 + 0b0.00010011101p+12 314 + 0b100111010000p-3 314 + 0x1.921fb5p+1 3.14159262180328369140625e+0 + 0o1.2677025p1 2.71828174591064453125 + 01.2677025p1 2.71828174591064453125 0b1.1001p-4 9.765625e-2 =head2 Output @@ -5680,10 +6447,11 @@ supplied to the operation after the I<scale>: Math::BigFloat->round_mode('zero'); $y = $x->copy()->bdiv(3,6); # will also give 0.666667 -Note that C<< Math::BigFloat->accuracy() >> and C<< Math::BigFloat->precision() >> -set the global variables, and thus B<any> newly created number will be subject -to the global rounding B<immediately>. This means that in the examples above, the -C<3> as argument to C<bdiv()> will also get an accuracy of B<5>. +Note that C<< Math::BigFloat->accuracy() >> and +C<< Math::BigFloat->precision() >> set the global variables, and thus B<any> +newly created number will be subject to the global rounding B<immediately>. This +means that in the examples above, the C<3> as argument to C<bdiv()> will also +get an accuracy of B<5>. It is less confusing to either calculate the result fully, and afterwards round it explicitly, or use the additional parameters to the math @@ -5752,76 +6520,103 @@ C<as_number()>: $x = Math::BigFloat->new(2.5); $y = $x->as_number('odd'); # $y = 3 -=head1 Autocreating constants +=head1 NUMERIC LITERALS -After C<use Math::BigFloat ':constant'> all the floating point constants -in the given scope are converted to C<Math::BigFloat>. This conversion -happens at compile time. +After C<use Math::BigFloat ':constant'> all numeric literals in the given scope +are converted to C<Math::BigFloat> objects. This conversion happens at compile +time. -In particular +For example, - perl -MMath::BigFloat=:constant -e 'print 2E-100,"\n"' + perl -MMath::BigFloat=:constant -le 'print 2e-150' -prints the value of C<2E-100>. Note that without conversion of -constants the expression 2E-100 will be calculated as normal floating point -number. +prints the exact value of C<2e-150>. Note that without conversion of constants +the expression C<2e-150> is calculated using Perl scalars, which leads to an +inaccuracte result. -Please note that ':constant' does not affect integer constants, nor binary -nor hexadecimal constants. Use L<bignum> or L<Math::BigInt> to get this to -work. +Note that strings are not affected, so that -=head2 Math library + use Math::BigFloat qw/:constant/; -Math with the numbers is done (by default) by a module called -Math::BigInt::Calc. This is equivalent to saying: + $y = "1234567890123456789012345678901234567890" + + "123456789123456789"; - use Math::BigFloat lib => 'Calc'; +does not give you what you expect. You need an explicit Math::BigFloat->new() +around at least one of the operands. You should also quote large constants to +prevent loss of precision: -You can change this by using: + use Math::BigFloat; - use Math::BigFloat lib => 'GMP'; + $x = Math::BigFloat->new("1234567889123456789123456789123456789"); -B<Note>: General purpose packages should not be explicit about the library -to use; let the script author decide which is best. +Without the quotes Perl converts the large number to a floating point constant +at compile time, and then converts the result to a Math::BigFloat object at +runtime, which results in an inaccurate result. -Note: The keyword 'lib' will warn when the requested library could not be -loaded. To suppress the warning use 'try' instead: +=head2 Hexadecimal, octal, and binary floating point literals - use Math::BigFloat try => 'GMP'; +Perl (and this module) accepts hexadecimal, octal, and binary floating point +literals, but use them with care with Perl versions before v5.32.0, because some +versions of Perl silently give the wrong result. Below are some examples of +different ways to write the number decimal 314. -If your script works with huge numbers and Calc is too slow for them, -you can also for the loading of one of these libraries and if none -of them can be used, the code will die: +Hexadecimal floating point literals: - use Math::BigFloat only => 'GMP,Pari'; + 0x1.3ap+8 0X1.3AP+8 + 0x1.3ap8 0X1.3AP8 + 0x13a0p-4 0X13A0P-4 -The following would first try to find Math::BigInt::Foo, then -Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc: +Octal floating point literals (with "0" prefix): - use Math::BigFloat lib => 'Foo,Math::BigInt::Bar'; + 01.164p+8 01.164P+8 + 01.164p8 01.164P8 + 011640p-4 011640P-4 -See the respective low-level library documentation for further details. +Octal floating point literals (with "0o" prefix) (requires v5.34.0): -Please note that Math::BigFloat does B<not> use the denoted library itself, -but it merely passes the lib argument to Math::BigInt. So, instead of the need -to do: + 0o1.164p+8 0O1.164P+8 + 0o1.164p8 0O1.164P8 + 0o11640p-4 0O11640P-4 - use Math::BigInt lib => 'GMP'; - use Math::BigFloat; +Binary floating point literals: + + 0b1.0011101p+8 0B1.0011101P+8 + 0b1.0011101p8 0B1.0011101P8 + 0b10011101000p-2 0B10011101000P-2 -you can roll it all into one line: +=head2 Math library - use Math::BigFloat lib => 'GMP'; +Math with the numbers is done (by default) by a module called +Math::BigInt::Calc. This is equivalent to saying: -It is also possible to just require Math::BigFloat: + use Math::BigFloat lib => "Calc"; - require Math::BigFloat; +You can change this by using: + + use Math::BigFloat lib => "GMP"; + +B<Note>: General purpose packages should not be explicit about the library to +use; let the script author decide which is best. + +Note: The keyword 'lib' will warn when the requested library could not be +loaded. To suppress the warning use 'try' instead: + + use Math::BigFloat try => "GMP"; -This will load the necessary things (like BigInt) when they are needed, and -automatically. +If your script works with huge numbers and Calc is too slow for them, you can +also for the loading of one of these libraries and if none of them can be used, +the code will die: -See L<Math::BigInt> for more details than you ever wanted to know about using -a different low-level library. + use Math::BigFloat only => "GMP,Pari"; + +The following would first try to find Math::BigInt::Foo, then Math::BigInt::Bar, +and when this also fails, revert to Math::BigInt::Calc: + + use Math::BigFloat lib => "Foo,Math::BigInt::Bar"; + +See the respective low-level library documentation for further details. + +See L<Math::BigInt> for more details about using a different low-level library. =head2 Using Math::BigInt::Lite @@ -5835,7 +6630,8 @@ math library for directly storing the number parts. =head1 EXPORTS -C<Math::BigFloat> exports nothing by default, but can export the C<bpi()> method: +C<Math::BigFloat> exports nothing by default, but can export the C<bpi()> +method: use Math::BigFloat qw/bpi/; @@ -5910,7 +6706,8 @@ a certain number of digits: print "$z\n"; print $z->precision(),"\n"; # 4 -Replacing L</precision()> with L</accuracy()> is probably not what you want, either: +Replacing L</precision()> with L</accuracy()> is probably not what you want, +either: use Math::BigFloat; @@ -5944,8 +6741,7 @@ influence any further operation. Please report any bugs or feature requests to C<bug-math-bigint at rt.cpan.org>, or through the web interface at -L<https://rt.cpan.org/Ticket/Create.html?Queue=Math-BigInt> -(requires login). +L<https://rt.cpan.org/Ticket/Create.html?Queue=Math-BigInt> (requires login). We will be notified, and then you'll automatically be notified of progress on your bug as I make changes. @@ -5959,17 +6755,13 @@ You can also look for information at: =over 4 -=item * RT: CPAN's request tracker - -L<https://rt.cpan.org/Public/Dist/Display.html?Name=Math-BigInt> - -=item * AnnoCPAN: Annotated CPAN documentation +=item * GitHub -L<http://annocpan.org/dist/Math-BigInt> +L<https://github.com/pjacklam/p5-Math-BigInt> -=item * CPAN Ratings +=item * RT: CPAN's request tracker -L<https://cpanratings.perl.org/dist/Math-BigInt> +L<https://rt.cpan.org/Dist/Display.html?Name=Math-BigInt> =item * MetaCPAN @@ -5979,6 +6771,10 @@ L<https://metacpan.org/release/Math-BigInt> L<http://matrix.cpantesters.org/?dist=Math-BigInt> +=item * CPAN Ratings + +L<https://cpanratings.perl.org/dist/Math-BigInt> + =item * The Bignum mailing list =over 4 @@ -6006,11 +6802,10 @@ the same terms as Perl itself. =head1 SEE ALSO -L<Math::BigFloat> and L<Math::BigInt> as well as the backends +L<Math::BigInt> and L<Math::BigInt> as well as the backends L<Math::BigInt::FastCalc>, L<Math::BigInt::GMP>, and L<Math::BigInt::Pari>. -The pragmas L<bignum>, L<bigint> and L<bigrat> also might be of interest -because they solve the autoupgrading/downgrading issue, at least partly. +The pragmas L<bignum>, L<bigint> and L<bigrat>. =head1 AUTHORS @@ -6030,7 +6825,7 @@ Florian Ragwitz E<lt>flora@cpan.orgE<gt>, 2010. =item * -Peter John Acklam E<lt>pjacklam@online.noE<gt>, 2011-. +Peter John Acklam E<lt>pjacklam@gmail.comE<gt>, 2011-. =back diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigFloat/Trace.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigFloat/Trace.pm index 2fc069370a..14baa9f292 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigFloat/Trace.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigFloat/Trace.pm @@ -1,58 +1,76 @@ -#!perl +# -*- mode: perl; -*- package Math::BigFloat::Trace; -require 5.010; use strict; use warnings; use Exporter; use Math::BigFloat; -our ($accuracy, $precision, $round_mode, $div_scale); - our @ISA = qw(Exporter Math::BigFloat); -our $VERSION = '0.51'; +our $VERSION = '0.66'; use overload; # inherit overload from Math::BigFloat # Globals -$accuracy = $precision = undef; -$round_mode = 'even'; -$div_scale = 40; +our $accuracy = undef; +our $precision = undef; +our $round_mode = 'even'; +our $div_scale = 40; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $value = shift; + my $a = $accuracy; $a = $_[0] if defined $_[0]; + my $p = $precision; $p = $_[1] if defined $_[1]; - my $self = Math::BigFloat->new($value, $a, $p, $round_mode); - # remember, downgrading may return a BigInt, so don't meddle with class - # bless $self, $class; + my $self = $class -> SUPER::new($value, $a, $p, $round_mode); + + printf "Math::BigFloat new '%s' => '%s' (%s)\n", + $value, $self, ref($self); - print "MBF new '$value' => '$self' (", ref($self), ")"; return $self; } sub import { - print "MBF import ", join(' ', @_); - my $self = shift; + my $class = shift; + + printf "%s -> import(%s)\n", $class, join(", ", @_); + + # we catch the constants, the rest goes to parent + + my $constant = grep { $_ eq ':constant' } @_; + my @a = grep { $_ ne ':constant' } @_; + + if ($constant) { + overload::constant + + integer => sub { + $class -> new(shift); + }, + + float => sub { + $class -> new(shift); + }, - # we catch the constants, the rest goes go BigFloat - my @a = (); - foreach (@_) { - push @a, $_ if $_ ne ':constant'; + binary => sub { + # E.g., a literal 0377 shall result in an object whose value + # is decimal 255, but new("0377") returns decimal 377. + return $class -> from_oct($_[0]) if $_[0] =~ /^0_*[0-7]/; + $class -> new(shift); + }; } - overload::constant float => sub { $self->new(shift); }; - Math::BigFloat->import(@a); # need it for subclasses -# $self->export_to_level(1,$self,@_); # need this ? + $class -> SUPER::import(@a); # need it for subclasses + #$self -> export_to_level(1, $class, @_); # need this ? } 1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt.pm index 185f802835..65e14467bb 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt.pm @@ -20,9 +20,11 @@ use 5.006001; use strict; use warnings; -use Carp qw< carp croak >; +use Carp qw< carp croak >; +use Scalar::Util qw< blessed refaddr >; -our $VERSION = '1.999818'; +our $VERSION = '1.999837'; +$VERSION =~ tr/_//d; require Exporter; our @ISA = qw(Exporter); @@ -45,44 +47,43 @@ use overload '+' => sub { $_[0] -> copy() -> badd($_[1]); }, - '-' => sub { my $c = $_[0] -> copy; + '-' => sub { my $c = $_[0] -> copy(); $_[2] ? $c -> bneg() -> badd($_[1]) : $c -> bsub($_[1]); }, '*' => sub { $_[0] -> copy() -> bmul($_[1]); }, '/' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bdiv($_[0]) - : $_[0] -> copy -> bdiv($_[1]); }, + : $_[0] -> copy() -> bdiv($_[1]); }, '%' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bmod($_[0]) - : $_[0] -> copy -> bmod($_[1]); }, - + : $_[0] -> copy() -> bmod($_[1]); }, '**' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bpow($_[0]) - : $_[0] -> copy -> bpow($_[1]); }, + : $_[0] -> copy() -> bpow($_[1]); }, '<<' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> blsft($_[0]) - : $_[0] -> copy -> blsft($_[1]); }, + : $_[0] -> copy() -> blsft($_[1]); }, '>>' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> brsft($_[0]) - : $_[0] -> copy -> brsft($_[1]); }, + : $_[0] -> copy() -> brsft($_[1]); }, # overload key: assign - '+=' => sub { $_[0]->badd($_[1]); }, + '+=' => sub { $_[0] -> badd($_[1]); }, - '-=' => sub { $_[0]->bsub($_[1]); }, + '-=' => sub { $_[0] -> bsub($_[1]); }, - '*=' => sub { $_[0]->bmul($_[1]); }, + '*=' => sub { $_[0] -> bmul($_[1]); }, - '/=' => sub { scalar $_[0]->bdiv($_[1]); }, + '/=' => sub { scalar $_[0] -> bdiv($_[1]); }, - '%=' => sub { $_[0]->bmod($_[1]); }, + '%=' => sub { $_[0] -> bmod($_[1]); }, - '**=' => sub { $_[0]->bpow($_[1]); }, + '**=' => sub { $_[0] -> bpow($_[1]); }, - '<<=' => sub { $_[0]->blsft($_[1]); }, + '<<=' => sub { $_[0] -> blsft($_[1]); }, - '>>=' => sub { $_[0]->brsft($_[1]); }, + '>>=' => sub { $_[0] -> brsft($_[1]); }, # 'x=' => sub { }, @@ -116,13 +117,13 @@ use overload # overload key: str_comparison -# 'lt' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrlt($_[0]) +# 'lt' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrlt($_[0]) # : $_[0] -> bstrlt($_[1]); }, # # 'le' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrle($_[0]) # : $_[0] -> bstrle($_[1]); }, # -# 'gt' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrgt($_[0]) +# 'gt' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrgt($_[0]) # : $_[0] -> bstrgt($_[1]); }, # # 'ge' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrge($_[0]) @@ -135,17 +136,17 @@ use overload # overload key: binary '&' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> band($_[0]) - : $_[0] -> copy -> band($_[1]); }, + : $_[0] -> copy() -> band($_[1]); }, '&=' => sub { $_[0] -> band($_[1]); }, '|' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bior($_[0]) - : $_[0] -> copy -> bior($_[1]); }, + : $_[0] -> copy() -> bior($_[1]); }, '|=' => sub { $_[0] -> bior($_[1]); }, '^' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bxor($_[0]) - : $_[0] -> copy -> bxor($_[1]); }, + : $_[0] -> copy() -> bxor($_[1]); }, '^=' => sub { $_[0] -> bxor($_[1]); }, @@ -182,9 +183,9 @@ use overload 'atan2' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> batan2($_[0]) : $_[0] -> copy() -> batan2($_[1]); }, - 'cos' => sub { $_[0] -> copy -> bcos(); }, + 'cos' => sub { $_[0] -> copy() -> bcos(); }, - 'sin' => sub { $_[0] -> copy -> bsin(); }, + 'sin' => sub { $_[0] -> copy() -> bsin(); }, 'exp' => sub { $_[0] -> copy() -> bexp($_[1]); }, @@ -204,7 +205,7 @@ use overload '0+' => sub { $_[0] -> numify(); }, - '=' => sub { $_[0]->copy(); }, + '=' => sub { $_[0] -> copy(); }, ; @@ -214,7 +215,8 @@ use overload # These vars are public, but their direct usage is not recommended, use the # accessor methods instead -our $round_mode = 'even'; # one of 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common' +# $round_mode is 'even', 'odd', '+inf', '-inf', 'zero', 'trunc', or 'common'. +our $round_mode = 'even'; our $accuracy = undef; our $precision = undef; our $div_scale = 40; @@ -228,11 +230,14 @@ our $_trap_inf = 0; # are infs ok? set w/ config() my $nan = 'NaN'; # constants for easier life -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 %CALLBACKS; # callbacks to notify on lib loads +# Module to do the low level math. + +my $DEFAULT_LIB = 'Math::BigInt::Calc'; +my $LIB; + +# Has import() been called yet? Needed to make "require" work. + +my $IMPORT = 0; ############################################################################## # the old code had $rnd_mode, so we need to support it, too @@ -257,9 +262,9 @@ BEGIN { tie $rnd_mode, 'Math::BigInt'; # set up some handy alias names - *as_int = \&as_number; *is_pos = \&is_positive; *is_neg = \&is_negative; + *as_number = \&as_int; } ############################################################################### @@ -267,18 +272,24 @@ BEGIN { ############################################################################### sub round_mode { - no strict 'refs'; - # make Class->round_mode() work my $self = shift; my $class = ref($self) || $self || __PACKAGE__; - if (defined $_[0]) { + + if (@_) { # setter my $m = shift; - if ($m !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/) { - croak("Unknown round mode '$m'"); - } - return ${"${class}::round_mode"} = $m; + croak("The value for 'round_mode' must be defined") + unless defined $m; + croak("Unknown round mode '$m'") + unless $m =~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/; + no strict 'refs'; + ${"${class}::round_mode"} = $m; + } + + else { # getter + no strict 'refs'; + my $m = ${"${class}::round_mode"}; + defined($m) ? $m : $round_mode; } - ${"${class}::round_mode"}; } sub upgrade { @@ -286,6 +297,7 @@ sub upgrade { # make Class->upgrade() work my $self = shift; my $class = ref($self) || $self || __PACKAGE__; + # need to set new value? if (@_ > 0) { return ${"${class}::upgrade"} = $_[0]; @@ -306,17 +318,23 @@ sub downgrade { } sub div_scale { - no strict 'refs'; - # make Class->div_scale() work my $self = shift; my $class = ref($self) || $self || __PACKAGE__; - if (defined $_[0]) { - if ($_[0] < 0) { - croak('div_scale must be greater than zero'); - } - ${"${class}::div_scale"} = $_[0]; + + if (@_) { # setter + my $ds = shift; + croak("The value for 'div_scale' must be defined") unless defined $ds; + croak("The value for 'div_scale' must be positive") unless $ds > 0; + $ds = $ds -> numify() if defined(blessed($ds)); + no strict 'refs'; + ${"${class}::div_scale"} = $ds; + } + + else { # getter + no strict 'refs'; + my $ds = ${"${class}::div_scale"}; + defined($ds) ? $ds : $div_scale; } - ${"${class}::div_scale"}; } sub accuracy { @@ -344,11 +362,11 @@ sub accuracy { if (ref($x)) { # Set instance variable. - $x->bround($a) if $a; # not for undef, 0 + $x = $x->bround($a) if $a; # not for undef, 0 $x->{_a} = $a; # set/overwrite, even if not rounded delete $x->{_p}; # clear P # Why return class variable here? Fixme! - $a = ${"${class}::accuracy"} unless defined $a; # proper return value + $a = ${"${class}::accuracy"} unless defined $a; } else { # Set class variable. ${"${class}::accuracy"} = $a; # set global A @@ -359,7 +377,7 @@ sub accuracy { } # Return instance variable. - return $x->{_a} if ref($x) && (defined $x->{_a} || defined $x->{_p}); + return $x->{_a} if ref($x) && (defined($x->{_a}) || defined($x->{_p})); # Return class variable. return ${"${class}::accuracy"}; @@ -386,11 +404,11 @@ sub precision { if (ref($x)) { # Set instance variable. - $x->bfround($p) if $p; # not for undef, 0 + $x = $x->bfround($p) if $p; # not for undef, 0 $x->{_p} = $p; # set/overwrite, even if not rounded delete $x->{_a}; # clear A # Why return class variable here? Fixme! - $p = ${"${class}::precision"} unless defined $p; # proper return value + $p = ${"${class}::precision"} unless defined $p; } else { # Set class variable. ${"${class}::precision"} = $p; # set global P @@ -401,7 +419,7 @@ sub precision { } # Return instance variable. - return $x->{_p} if ref($x) && (defined $x->{_a} || defined $x->{_p}); + return $x->{_p} if ref($x) && (defined($x->{_a}) || defined($x->{_p})); # Return class variable. return ${"${class}::precision"}; @@ -530,183 +548,195 @@ sub new { my $selfref = ref $self; my $class = $selfref || $self; - # The POD says: - # - # "Currently, Math::BigInt->new() defaults to 0, while Math::BigInt->new('') - # results in 'NaN'. This might change in the future, so use always the - # following explicit forms to get a zero or NaN: - # $zero = Math::BigInt->bzero(); - # $nan = Math::BigInt->bnan(); - # - # But although this use has been discouraged for more than 10 years, people - # apparently still use it, so we still support it. + # Make "require" work. - return $self->bzero() unless @_; + $class -> import() if $IMPORT == 0; - my ($wanted, $a, $p, $r) = @_; + # Calling new() with no input arguments has been discouraged for more than + # 10 years, but people apparently still use it, so we still support it. - # Always return a new object, so if called as an instance method, copy the - # invocand, and if called as a class method, initialize a new object. + return $class -> bzero() unless @_; - $self = $selfref ? $self -> copy() - : bless {}, $class; + my ($wanted, @r) = @_; - unless (defined $wanted) { - #carp("Use of uninitialized value in new()"); - return $self->bzero($a, $p, $r); + if (!defined($wanted)) { + #carp("Use of uninitialized value in new()") + # if warnings::enabled("uninitialized"); + return $class -> bzero(@r); } - if (ref($wanted) && $wanted->isa($class)) { # MBI or subclass - # Using "$copy = $wanted -> copy()" here fails some tests. Fixme! - my $copy = $class -> copy($wanted); - if ($selfref) { - %$self = %$copy; - } else { - $self = $copy; - } - return $self; + if (!ref($wanted) && $wanted eq "") { + #carp(q|Argument "" isn't numeric in new()|) + # if warnings::enabled("numeric"); + #return $class -> bzero(@r); + return $class -> bnan(@r); } - $class->import() if $IMPORT == 0; # make require work + # Initialize a new object. + + $self = bless {}, $class; + + # Math::BigInt or subclass + + if (defined(blessed($wanted)) && $wanted -> isa($class)) { + + # Don't copy the accuracy and precision, because a new object should get + # them from the global configuration. + + $self -> {sign} = $wanted -> {sign}; + $self -> {value} = $LIB -> _copy($wanted -> {value}); + $self = $self->round(@r) + unless @r >= 2 && !defined($r[0]) && !defined($r[1]); + return $self; + } # Shortcut for non-zero scalar integers with no non-zero exponent. - if (!ref($wanted) && - $wanted =~ / ^ - ([+-]?) # optional sign - ([1-9][0-9]*) # non-zero significand - (\.0*)? # ... with optional zero fraction - ([Ee][+-]?0+)? # optional zero exponent - \z - /x) + if ($wanted =~ + / ^ + ( [+-]? ) # optional sign + ( [1-9] [0-9]* ) # non-zero significand + ( \.0* )? # ... with optional zero fraction + ( [Ee] [+-]? 0+ )? # optional zero exponent + \z + /x) { my $sgn = $1; my $abs = $2; $self->{sign} = $sgn || '+'; $self->{value} = $LIB->_new($abs); - - no strict 'refs'; - if (defined($a) || defined($p) - || defined(${"${class}::precision"}) - || defined(${"${class}::accuracy"})) - { - $self->round($a, $p, $r) - unless @_ >= 3 && !defined $a && !defined $p; - } - + $self = $self->round(@r); return $self; } # Handle Infs. - if ($wanted =~ /^\s*([+-]?)inf(inity)?\s*\z/i) { + if ($wanted =~ / ^ + \s* + ( [+-]? ) + inf (?: inity )? + \s* + \z + /ix) + { my $sgn = $1 || '+'; - $self->{sign} = $sgn . 'inf'; # set a default sign for bstr() - return $class->binf($sgn); + return $class -> binf($sgn, @r); } # Handle explicit NaNs (not the ones returned due to invalid input). - if ($wanted =~ /^\s*([+-]?)nan\s*\z/i) { - $self = $class -> bnan(); - $self->round($a, $p, $r) unless @_ >= 3 && !defined $a && !defined $p; - return $self; + if ($wanted =~ / ^ + \s* + ( [+-]? ) + nan + \s* + \z + /ix) + { + return $class -> bnan(@r); } - # Handle hexadecimal numbers. + my @parts; - if ($wanted =~ /^\s*[+-]?0[Xx]/) { - $self = $class -> from_hex($wanted); - $self->round($a, $p, $r) unless @_ >= 3 && !defined $a && !defined $p; - return $self; - } + if ( + # Handle hexadecimal numbers. We auto-detect hexadecimal numbers if they + # have a "0x", "0X", "x", or "X" prefix, cf. CORE::oct(). - # Handle binary numbers. + $wanted =~ /^\s*[+-]?0?[Xx]/ and + @parts = $class -> _hex_str_to_flt_lib_parts($wanted) - if ($wanted =~ /^\s*[+-]?0[Bb]/) { - $self = $class -> from_bin($wanted); - $self->round($a, $p, $r) unless @_ >= 3 && !defined $a && !defined $p; - return $self; - } + or - # Split string into mantissa, exponent, integer, fraction, value, and sign. - my ($mis, $miv, $mfv, $es, $ev) = _split($wanted); - if (!ref $mis) { - if ($_trap_nan) { - croak("$wanted is not a number in $class"); - } - $self->{value} = $LIB->_zero(); - $self->{sign} = $nan; - return $self; - } + # Handle octal numbers. We auto-detect octal numbers if they have a + # "0o", "0O", "o", "O" prefix, cf. CORE::oct(). - if (!ref $miv) { - # _from_hex or _from_bin - $self->{value} = $mis->{value}; - $self->{sign} = $mis->{sign}; - return $self; # throw away $mis - } + $wanted =~ /^\s*[+-]?0?[Oo]/ and + @parts = $class -> _oct_str_to_flt_lib_parts($wanted) - # Make integer from mantissa by adjusting exponent, then convert to a - # Math::BigInt. - $self->{sign} = $$mis; # store sign - $self->{value} = $LIB->_zero(); # for all the NaN cases - my $e = int("$$es$$ev"); # exponent (avoid recursion) - if ($e > 0) { - my $diff = $e - CORE::length($$mfv); - if ($diff < 0) { # Not integer - if ($_trap_nan) { - croak("$wanted not an integer in $class"); - } - #print "NOI 1\n"; - return $upgrade->new($wanted, $a, $p, $r) if defined $upgrade; - $self->{sign} = $nan; - } else { # diff >= 0 - # adjust fraction and add it to value - #print "diff > 0 $$miv\n"; - $$miv = $$miv . ($$mfv . '0' x $diff); + or + + # Handle binary numbers. We auto-detect binary numbers if they have a + # "0b", "0B", "b", or "B" prefix, cf. CORE::oct(). + + $wanted =~ /^\s*[+-]?0?[Bb]/ and + @parts = $class -> _bin_str_to_flt_lib_parts($wanted) + + or + + # At this point, what is left are decimal numbers that aren't handled + # above and octal floating point numbers that don't have any of the + # "0o", "0O", "o", or "O" prefixes. First see if it is a decimal number. + + @parts = $class -> _dec_str_to_flt_lib_parts($wanted) + or + + # See if it is an octal floating point number. The extra check is + # included because _oct_str_to_flt_lib_parts() accepts octal numbers + # that don't have a prefix (this is needed to make it work with, e.g., + # from_oct() that don't require a prefix). However, Perl requires a + # prefix for octal floating point literals. For example, "1p+0" is not + # valid, but "01p+0" and "0__1p+0" are. + + $wanted =~ /^\s*[+-]?0_*\d/ and + @parts = $class -> _oct_str_to_flt_lib_parts($wanted)) + { + # The value is an integer iff the exponent is non-negative. + + if ($parts[2] eq '+') { + $self -> {sign} = $parts[0]; + $self -> {value} = $LIB -> _lsft($parts[1], $parts[3], 10); + $self = $self->round(@r) + unless @r >= 2 && !defined($r[0]) && !defined($r[1]); + return $self; } + + # The value is not an integer, so upgrade if upgrading is enabled. + + return $upgrade -> new($wanted, @r) if defined $upgrade; } - else { - if ($$mfv ne '') { # e <= 0 - # fraction and negative/zero E => NOI - if ($_trap_nan) { - croak("$wanted not an integer in $class"); - } - #print "NOI 2 \$\$mfv '$$mfv'\n"; - return $upgrade->new($wanted, $a, $p, $r) if defined $upgrade; - $self->{sign} = $nan; - } elsif ($e < 0) { - # xE-y, and empty mfv - # Split the mantissa at the decimal point. E.g., if - # $$miv = 12345 and $e = -2, then $frac = 45 and $$miv = 123. - - my $frac = substr($$miv, $e); # $frac is fraction part - substr($$miv, $e) = ""; # $$miv is now integer part - - if ($frac =~ /[^0]/) { - if ($_trap_nan) { - croak("$wanted not an integer in $class"); - } - #print "NOI 3\n"; - return $upgrade->new($wanted, $a, $p, $r) if defined $upgrade; - $self->{sign} = $nan; - } + # If we get here, the value is neither a valid decimal, binary, octal, or + # hexadecimal number. It is not explicit an Inf or a NaN either. + + return $class -> bnan(@r); +} + +# Create a Math::BigInt from a decimal string. This is an equivalent to +# from_hex(), from_oct(), and from_bin(). It is like new() except that it does +# not accept anything but a string representing a finite decimal number. + +sub from_dec { + my $self = shift; + my $selfref = ref $self; + my $class = $selfref || $self; + + # Don't modify constant (read-only) objects. + + return $self if $selfref && $self->modify('from_dec'); + + my $str = shift; + my @r = @_; + + # If called as a class method, initialize a new object. + + $self = $class -> bzero(@r) unless $selfref; + + if (my @parts = $class -> _dec_str_to_flt_lib_parts($str)) { + + # The value is an integer iff the exponent is non-negative. + + if ($parts[2] eq '+') { + $self -> {sign} = $parts[0]; + $self -> {value} = $LIB -> _lsft($parts[1], $parts[3], 10); + return $self -> round(@r); } - } - unless ($self->{sign} eq $nan) { - $self->{sign} = '+' if $$miv eq '0'; # normalize -0 => +0 - $self->{value} = $LIB->_new($$miv) if $self->{sign} =~ /^[+-]$/; - } + # The value is not an integer, so upgrade if upgrading is enabled. - # If any of the globals are set, use them to round, and store them inside - # $self. Do not round for new($x, undef, undef) since that is used by MBF - # to signal no rounding. + return $upgrade -> new($str, @r) if defined $upgrade; + } - $self->round($a, $p, $r) unless @_ >= 3 && !defined $a && !defined $p; - $self; + return $self -> bnan(@r); } # Create a Math::BigInt from a hexadecimal string. @@ -718,51 +748,31 @@ sub from_hex { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('from_hex'); + return $self if $selfref && $self->modify('from_hex'); my $str = shift; + my @r = @_; # If called as a class method, initialize a new object. - $self = $class -> bzero() unless $selfref; + $self = $class -> bzero(@r) unless $selfref; - if ($str =~ s/ - ^ - \s* - ( [+-]? ) - (0?x)? - ( - [0-9a-fA-F]* - ( _ [0-9a-fA-F]+ )* - ) - \s* - $ - //x) - { - # Get a "clean" version of the string, i.e., non-emtpy and with no - # underscores or invalid characters. - - my $sign = $1; - my $chrs = $3; - $chrs =~ tr/_//d; - $chrs = '0' unless CORE::length $chrs; + if (my @parts = $class -> _hex_str_to_flt_lib_parts($str)) { - # The library method requires a prefix. + # The value is an integer iff the exponent is non-negative. - $self->{value} = $LIB->_from_hex('0x' . $chrs); - - # Place the sign. + if ($parts[2] eq '+') { + $self -> {sign} = $parts[0]; + $self -> {value} = $LIB -> _lsft($parts[1], $parts[3], 10); + return $self -> round(@r); + } - $self->{sign} = $sign eq '-' && ! $LIB->_is_zero($self->{value}) - ? '-' : '+'; + # The value is not an integer, so upgrade if upgrading is enabled. - return $self; + return $upgrade -> new($str, @r) if defined $upgrade; } - # CORE::hex() parses as much as it can, and ignores any trailing garbage. - # For backwards compatibility, we return NaN. - - return $self->bnan(); + return $self -> bnan(@r); } # Create a Math::BigInt from an octal string. @@ -774,50 +784,31 @@ sub from_oct { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('from_oct'); + return $self if $selfref && $self->modify('from_oct'); my $str = shift; + my @r = @_; # If called as a class method, initialize a new object. - $self = $class -> bzero() unless $selfref; - - if ($str =~ s/ - ^ - \s* - ( [+-]? ) - ( - [0-7]* - ( _ [0-7]+ )* - ) - \s* - $ - //x) - { - # Get a "clean" version of the string, i.e., non-emtpy and with no - # underscores or invalid characters. - - my $sign = $1; - my $chrs = $2; - $chrs =~ tr/_//d; - $chrs = '0' unless CORE::length $chrs; + $self = $class -> bzero(@r) unless $selfref; - # The library method requires a prefix. + if (my @parts = $class -> _oct_str_to_flt_lib_parts($str)) { - $self->{value} = $LIB->_from_oct('0' . $chrs); + # The value is an integer iff the exponent is non-negative. - # Place the sign. + if ($parts[2] eq '+') { + $self -> {sign} = $parts[0]; + $self -> {value} = $LIB -> _lsft($parts[1], $parts[3], 10); + return $self -> round(@r); + } - $self->{sign} = $sign eq '-' && ! $LIB->_is_zero($self->{value}) - ? '-' : '+'; + # The value is not an integer, so upgrade if upgrading is enabled. - return $self; + return $upgrade -> new($str, @r) if defined $upgrade; } - # CORE::oct() parses as much as it can, and ignores any trailing garbage. - # For backwards compatibility, we return NaN. - - return $self->bnan(); + return $self -> bnan(@r); } # Create a Math::BigInt from a binary string. @@ -829,52 +820,31 @@ sub from_bin { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('from_bin'); + return $self if $selfref && $self->modify('from_bin'); my $str = shift; + my @r = @_; # If called as a class method, initialize a new object. - $self = $class -> bzero() unless $selfref; - - if ($str =~ s/ - ^ - \s* - ( [+-]? ) - (0?b)? - ( - [01]* - ( _ [01]+ )* - ) - \s* - $ - //x) - { - # Get a "clean" version of the string, i.e., non-emtpy and with no - # underscores or invalid characters. - - my $sign = $1; - my $chrs = $3; - $chrs =~ tr/_//d; - $chrs = '0' unless CORE::length $chrs; + $self = $class -> bzero(@r) unless $selfref; - # The library method requires a prefix. + if (my @parts = $class -> _bin_str_to_flt_lib_parts($str)) { - $self->{value} = $LIB->_from_bin('0b' . $chrs); + # The value is an integer iff the exponent is non-negative. - # Place the sign. + if ($parts[2] eq '+') { + $self -> {sign} = $parts[0]; + $self -> {value} = $LIB -> _lsft($parts[1], $parts[3], 10); + return $self -> round(@r); + } - $self->{sign} = $sign eq '-' && ! $LIB->_is_zero($self->{value}) - ? '-' : '+'; + # The value is not an integer, so upgrade if upgrading is enabled. - return $self; + return $upgrade -> new($str, @r) if defined $upgrade; } - # For consistency with from_hex() and from_oct(), we return NaN when the - # input is invalid. - - return $self->bnan(); - + return $self -> bnan(@r); } # Create a Math::BigInt from a byte string. @@ -886,19 +856,20 @@ sub from_bytes { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('from_bytes'); + return $self if $selfref && $self->modify('from_bytes'); croak("from_bytes() requires a newer version of the $LIB library.") unless $LIB->can('_from_bytes'); my $str = shift; + my @r = @_; # If called as a class method, initialize a new object. - $self = $class -> bzero() unless $selfref; + $self = $class -> bzero(@r) unless $selfref; $self -> {sign} = '+'; $self -> {value} = $LIB -> _from_bytes($str); - return $self; + return $self -> round(@r); } sub from_base { @@ -908,11 +879,10 @@ sub from_base { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('from_base'); + return $self if $selfref && $self->modify('from_base'); - my $str = shift; + my ($str, $base, $cs, @r) = @_; # $cs is the collation sequence - my $base = shift; $base = $class->new($base) unless ref($base); croak("the base must be a finite integer >= 2") @@ -925,14 +895,15 @@ sub from_base { # If no collating sequence is given, pass some of the conversions to # methods optimized for those cases. - if (! @_) { - return $self -> from_bin($str) if $base == 2; - return $self -> from_oct($str) if $base == 8; - return $self -> from_hex($str) if $base == 16; + unless (defined $cs) { + return $self -> from_bin($str, @r) if $base == 2; + return $self -> from_oct($str, @r) if $base == 8; + return $self -> from_hex($str, @r) if $base == 16; if ($base == 10) { - my $tmp = $class -> new($str); + my $tmp = $class -> from_dec($str, @r); $self -> {value} = $tmp -> {value}; $self -> {sign} = '+'; + return $self -> bround(@r); } } @@ -941,16 +912,61 @@ sub from_base { $self -> {sign} = '+'; $self -> {value} - = $LIB->_from_base($str, $base -> {value}, @_ ? shift() : ()); - return $self + = $LIB->_from_base($str, $base -> {value}, defined($cs) ? $cs : ()); + return $self -> bround(@r); +} + +sub from_base_num { + my $self = shift; + my $selfref = ref $self; + my $class = $selfref || $self; + + # Don't modify constant (read-only) objects. + + return $self if $selfref && $self->modify('from_base_num'); + + # Make sure we have an array of non-negative, finite, numerical objects. + + my $nums = shift; + $nums = [ @$nums ]; # create new reference + + for my $i (0 .. $#$nums) { + # Make sure we have an object. + $nums -> [$i] = $class -> new($nums -> [$i]) + unless ref($nums -> [$i]) && $nums -> [$i] -> isa($class); + # Make sure we have a finite, non-negative integer. + croak "the elements must be finite non-negative integers" + if $nums -> [$i] -> is_neg() || ! $nums -> [$i] -> is_int(); + } + + my $base = shift; + $base = $class -> new($base) unless ref($base) && $base -> isa($class); + + my @r = @_; + + # If called as a class method, initialize a new object. + + $self = $class -> bzero(@r) unless $selfref; + + croak("from_base_num() requires a newer version of the $LIB library.") + unless $LIB->can('_from_base_num'); + + $self -> {sign} = '+'; + $self -> {value} = $LIB -> _from_base_num([ map { $_ -> {value} } @$nums ], + $base -> {value}); + + return $self -> round(@r); } sub bzero { # create/assign '+0' - if (@_ == 0) { - #carp("Using bzero() as a function is deprecated;", - # " use bzero() as a method instead"); + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) + { + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; unshift @_, __PACKAGE__; } @@ -962,7 +978,13 @@ sub bzero { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('bzero'); + return $self if $selfref && $self->modify('bzero'); + + # Get the rounding parameters, if any. + + my @r = @_; + + # If called as a class method, initialize a new object. $self = bless {}, $class unless $selfref; @@ -970,19 +992,17 @@ sub bzero { $self->{value} = $LIB->_zero(); # If rounding parameters are given as arguments, use them. If no rounding - # parameters are given, and if called as a class method initialize the new + # parameters are given, and if called as a class method, initialize the new # instance with the class variables. - if (@_) { + if (@r) { croak "can't specify both accuracy and precision" - if @_ >= 2 && defined $_[0] && defined $_[1]; + if @r >= 2 && defined($r[0]) && defined($r[1]); $self->{_a} = $_[0]; $self->{_p} = $_[1]; - } else { - unless($selfref) { - $self->{_a} = $class -> accuracy(); - $self->{_p} = $class -> precision(); - } + } elsif (!$selfref) { + $self->{_a} = $class -> accuracy(); + $self->{_p} = $class -> precision(); } return $self; @@ -991,9 +1011,12 @@ sub bzero { sub bone { # Create or assign '+1' (or -1 if given sign '-'). - if (@_ == 0 || (defined($_[0]) && ($_[0] eq '+' || $_[0] eq '-'))) { - #carp("Using bone() as a function is deprecated;", - # " use bone() as a method instead"); + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) + { + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; unshift @_, __PACKAGE__; } @@ -1005,33 +1028,38 @@ sub bone { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('bone'); + return $self if $selfref && $self->modify('bone'); + + my ($sign, @r) = @_; - my $sign = '+'; # default - if (@_) { - $sign = shift; - $sign = $sign =~ /^\s*-/ ? "-" : "+"; + # Get the sign. + + if (defined($_[0]) && $_[0] =~ /^\s*([+-])\s*$/) { + $sign = $1; + shift; + } else { + $sign = '+'; } + # If called as a class method, initialize a new object. + $self = bless {}, $class unless $selfref; $self->{sign} = $sign; $self->{value} = $LIB->_one(); # If rounding parameters are given as arguments, use them. If no rounding - # parameters are given, and if called as a class method initialize the new + # parameters are given, and if called as a class method, initialize the new # instance with the class variables. - if (@_) { + if (@r) { croak "can't specify both accuracy and precision" - if @_ >= 2 && defined $_[0] && defined $_[1]; + if @r >= 2 && defined($r[0]) && defined($r[1]); $self->{_a} = $_[0]; $self->{_p} = $_[1]; - } else { - unless($selfref) { - $self->{_a} = $class -> accuracy(); - $self->{_p} = $class -> precision(); - } + } elsif (!$selfref) { + $self->{_a} = $class -> accuracy(); + $self->{_p} = $class -> precision(); } return $self; @@ -1040,11 +1068,12 @@ sub bone { sub binf { # create/assign a '+inf' or '-inf' - if (@_ == 0 || (defined($_[0]) && !ref($_[0]) && - $_[0] =~ /^\s*[+-](inf(inity)?)?\s*$/)) + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) { - #carp("Using binf() as a function is deprecated;", - # " use binf() as a method instead"); + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; unshift @_, __PACKAGE__; } @@ -1063,10 +1092,21 @@ sub binf { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('binf'); + return $self if $selfref && $self->modify('binf'); - my $sign = shift; - $sign = defined $sign && $sign =~ /^\s*-/ ? "-" : "+"; + # Get the sign. + + my $sign = '+'; # default is to return positive infinity + if (defined($_[0]) && $_[0] =~ /^\s*([+-])(inf|$)/i) { + $sign = $1; + shift; + } + + # Get the rounding parameters, if any. + + my @r = @_; + + # If called as a class method, initialize a new object. $self = bless {}, $class unless $selfref; @@ -1074,19 +1114,17 @@ sub binf { $self -> {value} = $LIB -> _zero(); # If rounding parameters are given as arguments, use them. If no rounding - # parameters are given, and if called as a class method initialize the new + # parameters are given, and if called as a class method, initialize the new # instance with the class variables. - if (@_) { + if (@r) { croak "can't specify both accuracy and precision" - if @_ >= 2 && defined $_[0] && defined $_[1]; + if @r >= 2 && defined($r[0]) && defined($r[1]); $self->{_a} = $_[0]; $self->{_p} = $_[1]; - } else { - unless($selfref) { - $self->{_a} = $class -> accuracy(); - $self->{_p} = $class -> precision(); - } + } elsif (!$selfref) { + $self->{_a} = $class -> accuracy(); + $self->{_p} = $class -> precision(); } return $self; @@ -1095,9 +1133,12 @@ sub binf { sub bnan { # create/assign a 'NaN' - if (@_ == 0) { - #carp("Using bnan() as a function is deprecated;", - # " use bnan() as a method instead"); + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) + { + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; unshift @_, __PACKAGE__; } @@ -1116,57 +1157,173 @@ sub bnan { # Don't modify constant (read-only) objects. - return if $selfref && $self->modify('bnan'); + return $self if $selfref && $self->modify('bnan'); + + # Get the rounding parameters, if any. + + my @r = @_; $self = bless {}, $class unless $selfref; $self -> {sign} = $nan; $self -> {value} = $LIB -> _zero(); + # If rounding parameters are given as arguments, use them. If no rounding + # parameters are given, and if called as a class method, initialize the new + # instance with the class variables. + + if (@r) { + croak "can't specify both accuracy and precision" + if @r >= 2 && defined($r[0]) && defined($r[1]); + $self->{_a} = $_[0]; + $self->{_p} = $_[1]; + } elsif (!$selfref) { + $self->{_a} = $class -> accuracy(); + $self->{_p} = $class -> precision(); + } + return $self; } sub bpi { - # Calculate PI to N digits. Unless upgrading is in effect, returns the - # result truncated to an integer, that is, always returns '3'. - my ($self, $n) = @_; - if (@_ == 1) { - # called like Math::BigInt::bpi(10); - $n = $self; - $self = __PACKAGE__; - } - $self = ref($self) if ref($self); - return $upgrade->new($n) if defined $upgrade; + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) + { + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; + unshift @_, __PACKAGE__; + } - # hard-wired to "3" - $self->new(3); -} + # Called as Argument list + # --------- ------------- + # Math::BigFloat->bpi() ("Math::BigFloat") + # Math::BigFloat->bpi(10) ("Math::BigFloat", 10) + # $x->bpi() ($x) + # $x->bpi(10) ($x, 10) + # Math::BigFloat::bpi() () + # Math::BigFloat::bpi(10) (10) + # + # In ambiguous cases, we favour the OO-style, so the following case + # + # $n = Math::BigFloat->new("10"); + # $x = Math::BigFloat->bpi($n); + # + # which gives an argument list with the single element $n, is resolved as + # + # $n->bpi(); -sub copy { my $self = shift; my $selfref = ref $self; my $class = $selfref || $self; + my @r = @_; # rounding paramters + + if ($selfref) { # bpi() called as an instance method + return $self if $self -> modify('bpi'); + } else { # bpi() called as a class method + $self = bless {}, $class; # initialize new instance + } + + return $upgrade -> bpi(@r) if defined $upgrade; + + # hard-wired to "3" + $self -> {sign} = '+'; + $self -> {value} = $LIB -> _new("3"); + $self = $self -> round(@r); + return $self; +} - # If called as a class method, the object to copy is the next argument. +sub copy { + my ($x, $class); + if (ref($_[0])) { # $y = $x -> copy() + $x = shift; + $class = ref($x); + } else { # $y = Math::BigInt -> copy($y) + $class = shift; + $x = shift; + } - $self = shift() unless $selfref; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @_; my $copy = bless {}, $class; - $copy->{sign} = $self->{sign}; - $copy->{value} = $LIB->_copy($self->{value}); - $copy->{_a} = $self->{_a} if exists $self->{_a}; - $copy->{_p} = $self->{_p} if exists $self->{_p}; + $copy->{sign} = $x->{sign}; + $copy->{value} = $LIB->_copy($x->{value}); + $copy->{_a} = $x->{_a} if exists $x->{_a}; + $copy->{_p} = $x->{_p} if exists $x->{_p}; return $copy; } -sub as_number { - # An object might be asked to return itself as bigint on certain overloaded - # operations. This does exactly this, so that sub classes can simple inherit - # it or override with their own integer conversion routine. - $_[0]->copy(); +sub as_int { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # If called as an instance method, and the instance class is something we + # upgrade to, $x might not be a Math::BigInt, so don't just call copy(). + + return $x -> copy() if $x -> isa("Math::BigInt"); + + # disable upgrading and downgrading + + my $upg = Math::BigInt -> upgrade(); + my $dng = Math::BigInt -> downgrade(); + Math::BigInt -> upgrade(undef); + Math::BigInt -> downgrade(undef); + + my $y = Math::BigInt -> new($x); + + # reset upgrading and downgrading + + Math::BigInt -> upgrade($upg); + Math::BigInt -> downgrade($dng); + + return $y; +} + +sub as_float { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # disable upgrading and downgrading + + require Math::BigFloat; + my $upg = Math::BigFloat -> upgrade(); + my $dng = Math::BigFloat -> downgrade(); + Math::BigFloat -> upgrade(undef); + Math::BigFloat -> downgrade(undef); + + my $y = Math::BigFloat -> new($x); + + # reset upgrading and downgrading + + Math::BigFloat -> upgrade($upg); + Math::BigFloat -> downgrade($dng); + + return $y; +} + +sub as_rat { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # disable upgrading and downgrading + + require Math::BigRat; + my $upg = Math::BigRat -> upgrade(); + my $dng = Math::BigRat -> downgrade(); + Math::BigRat -> upgrade(undef); + Math::BigRat -> downgrade(undef); + + my $y = Math::BigRat -> new($x); + + # reset upgrading and downgrading + + Math::BigRat -> upgrade($upg); + Math::BigRat -> downgrade($dng); + + return $y; } ############################################################################### @@ -1175,7 +1332,7 @@ sub as_number { sub is_zero { # return true if arg (BINT or num_str) is zero (array '+', '0') - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); return 0 if $x->{sign} !~ /^\+$/; # -, NaN & +-inf aren't $LIB->_is_zero($x->{value}); @@ -1183,22 +1340,22 @@ sub is_zero { sub is_one { # return true if arg (BINT or num_str) is +1, or -1 if sign is given - my ($class, $x, $sign) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my (undef, $x, $sign) = ref($_[0]) ? (undef, @_) : objectify(1, @_); - $sign = '+' if !defined $sign || $sign ne '-'; + $sign = '+' if !defined($sign) || $sign ne '-'; return 0 if $x->{sign} ne $sign; # -1 != +1, NaN, +-inf aren't either $LIB->_is_one($x->{value}); } sub is_finite { - my $x = shift; + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); return $x->{sign} eq '+' || $x->{sign} eq '-'; } sub is_inf { # return true if arg (BINT or num_str) is +-inf - my ($class, $x, $sign) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my (undef, $x, $sign) = ref($_[0]) ? (undef, @_) : objectify(1, @_); if (defined $sign) { $sign = '[+-]inf' if $sign eq ''; # +- doesn't matter, only that's inf @@ -1210,14 +1367,14 @@ sub is_inf { sub is_nan { # return true if arg (BINT or num_str) is NaN - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); $x->{sign} eq $nan ? 1 : 0; } sub is_positive { # return true when arg (BINT or num_str) is positive (> 0) - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); return 1 if $x->{sign} eq '+inf'; # +inf is positive @@ -1227,14 +1384,14 @@ sub is_positive { sub is_negative { # return true when arg (BINT or num_str) is negative (< 0) - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); $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,@_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); return 1 if $x->{sign} =~ /^\+/; return 1 if $x -> is_zero(); @@ -1243,7 +1400,7 @@ sub is_non_negative { sub is_non_positive { # Return true if argument is non-positive (<= 0). - my ($class, $x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); return 1 if $x->{sign} =~ /^\-/; return 1 if $x -> is_zero(); @@ -1252,7 +1409,7 @@ sub is_non_positive { 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, @_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't $LIB->_is_odd($x->{value}); @@ -1260,7 +1417,7 @@ sub is_odd { sub is_even { # return true when arg (BINT or num_str) is even, false for odd - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't $LIB->_is_even($x->{value}); @@ -1268,8 +1425,7 @@ sub is_even { sub is_int { # return true when arg (BINT or num_str) is an integer - # always true for Math::BigInt, but different for Math::BigFloat objects - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); $x->{sign} =~ /^[+-]$/ ? 1 : 0; # inf/-inf/NaN aren't } @@ -1283,22 +1439,25 @@ sub bcmp { # (BINT or num_str, BINT or num_str) return cond_code # set up parameters - my ($class, $x, $y) = ref($_[0]) && ref($_[0]) eq ref($_[1]) - ? (ref($_[0]), @_) - : objectify(2, @_); + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); - return $upgrade->bcmp($x, $y) if defined $upgrade && - ((!$x->isa($class)) || (!$y->isa($class))); + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + return $upgrade->bcmp($x, $y) + if defined($upgrade) && (!$x->isa($class) || !$y->isa($class)); if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/)) { # handle +-inf and NaN - return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); - return 0 if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/; + return if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); + return 0 if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/; return +1 if $x->{sign} eq '+inf'; return -1 if $x->{sign} eq '-inf'; return -1 if $y->{sign} eq '+inf'; return +1; } + # check sign for speed first return 1 if $x->{sign} eq '+' && $y->{sign} eq '-'; # does also 0 <=> -y return -1 if $x->{sign} eq '-' && $y->{sign} eq '+'; # does also -x <=> 0 @@ -1323,16 +1482,18 @@ sub bacmp { # (BINT, BINT) return cond_code # set up parameters - my ($class, $x, $y) = ref($_[0]) && ref($_[0]) eq ref($_[1]) - ? (ref($_[0]), @_) - : objectify(2, @_); + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - return $upgrade->bacmp($x, $y) if defined $upgrade && - ((!$x->isa($class)) || (!$y->isa($class))); + return $upgrade->bacmp($x, $y) + if defined($upgrade) && (!$x->isa($class) || !$y->isa($class)); if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/)) { # handle +-inf and NaN - return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); + return if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); return 0 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/; return 1 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} !~ /^[+-]inf$/; return -1; @@ -1341,69 +1502,68 @@ sub bacmp { } sub beq { - my $self = shift; - my $selfref = ref $self; + my (undef, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (undef, @_) + : objectify(2, @_); - croak 'beq() is an instance method, not a class method' unless $selfref; - croak 'Wrong number of arguments for beq()' unless @_ == 1; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - my $cmp = $self -> bcmp(shift); - return defined($cmp) && ! $cmp; + my $cmp = $x -> bcmp($y); # bcmp() upgrades if necessary + return defined($cmp) && !$cmp; } sub bne { - my $self = shift; - my $selfref = ref $self; + my (undef, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (undef, @_) + : objectify(2, @_); - croak 'bne() is an instance method, not a class method' unless $selfref; - croak 'Wrong number of arguments for bne()' unless @_ == 1; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - my $cmp = $self -> bcmp(shift); - return defined($cmp) && ! $cmp ? '' : 1; + my $cmp = $x -> bcmp($y); # bcmp() upgrades if necessary + return defined($cmp) && !$cmp ? '' : 1; } sub blt { - my $self = shift; - my $selfref = ref $self; + my (undef, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (undef, @_) + : objectify(2, @_); - croak 'blt() is an instance method, not a class method' unless $selfref; - croak 'Wrong number of arguments for blt()' unless @_ == 1; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - my $cmp = $self -> bcmp(shift); + my $cmp = $x -> bcmp($y); # bcmp() upgrades if necessary return defined($cmp) && $cmp < 0; } sub ble { - my $self = shift; - my $selfref = ref $self; + my (undef, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (undef, @_) + : objectify(2, @_); - croak 'ble() is an instance method, not a class method' unless $selfref; - croak 'Wrong number of arguments for ble()' unless @_ == 1; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - my $cmp = $self -> bcmp(shift); + my $cmp = $x -> bcmp($y); # bcmp() upgrades if necessary return defined($cmp) && $cmp <= 0; } sub bgt { - my $self = shift; - my $selfref = ref $self; + my (undef, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (undef, @_) + : objectify(2, @_); - croak 'bgt() is an instance method, not a class method' unless $selfref; - croak 'Wrong number of arguments for bgt()' unless @_ == 1; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - my $cmp = $self -> bcmp(shift); + my $cmp = $x -> bcmp($y); # bcmp() upgrades if necessary return defined($cmp) && $cmp > 0; } sub bge { - my $self = shift; - my $selfref = ref $self; + my (undef, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (undef, @_) + : objectify(2, @_); - croak 'bge() is an instance method, not a class method' - unless $selfref; - croak 'Wrong number of arguments for bge()' unless @_ == 1; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - my $cmp = $self -> bcmp(shift); + my $cmp = $x -> bcmp($y); # bcmp() upgrades if necessary return defined($cmp) && $cmp >= 0; } @@ -1414,84 +1574,104 @@ sub bge { sub bneg { # (BINT or num_str) return BINT # negate number or make a negated number from string - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('bneg'); - # for +0 do not negate (to have always normalized +0). Does nothing for 'NaN' - $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $LIB->_is_zero($x->{value})); - $x; + return $upgrade -> bneg($x, @r) if defined($upgrade) && !$x->isa($class); + + # Don't negate +0 so we always have the normalized form +0. Does nothing for + # 'NaN'. + $x->{sign} =~ tr/+-/-+/ + unless $x->{sign} eq '+' && $LIB->_is_zero($x->{value}); + + $x -> round(@r); } sub babs { # (BINT or num_str) return BINT # make number absolute, or return absolute BINT from string - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('babs'); - # post-normalized abs for internal use (does nothing for NaN) + + return $upgrade -> babs($x, @r) if defined($upgrade) && !$x->isa($class); + $x->{sign} =~ s/^-/+/; - $x; + + $x -> round(@r); } sub bsgn { # Signum function. + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - my $self = shift; + return $x if $x->modify('bsgn'); + + return $upgrade -> bsgn($x, @r) if defined($upgrade) && !$x->isa($class); - return $self if $self->modify('bsgn'); + return $x -> bone("+", @r) if $x -> is_pos(); + return $x -> bone("-", @r) if $x -> is_neg(); - return $self -> bone("+") if $self -> is_pos(); - return $self -> bone("-") if $self -> is_neg(); - return $self; # zero or NaN + $x -> round(@r); } sub bnorm { # (numstr or BINT) return BINT # Normalize number -- no-op here - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + + # This method is called from the rounding methods, so if this method + # supports rounding by calling the rounding methods, we get an infinite + # recursion. + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + $x; } sub binc { # increment arg by one - my ($class, $x, $a, $p, $r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + return $x if $x->modify('binc'); + return $x->round(@r) if $x -> is_inf() || $x -> is_nan(); + + return $upgrade -> binc($x, @r) if defined($upgrade) && !$x -> isa($class); + if ($x->{sign} eq '+') { $x->{value} = $LIB->_inc($x->{value}); - return $x->round($a, $p, $r); } elsif ($x->{sign} eq '-') { $x->{value} = $LIB->_dec($x->{value}); $x->{sign} = '+' if $LIB->_is_zero($x->{value}); # -1 +1 => -0 => +0 - return $x->round($a, $p, $r); } - # inf, nan handling etc - $x->badd($class->bone(), $a, $p, $r); # badd does round + + return $x->round(@r); } sub bdec { # decrement arg by one my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + return $x if $x->modify('bdec'); + return $x->round(@r) if $x -> is_inf() || $x -> is_nan(); + + return $upgrade -> bdec($x, @r) if defined($upgrade) && !$x -> isa($class);; + if ($x->{sign} eq '-') { - # x already < 0 $x->{value} = $LIB->_inc($x->{value}); - } else { - return $x->badd($class->bone('-'), @r) - unless $x->{sign} eq '+'; # inf or NaN - # >= 0 - if ($LIB->_is_zero($x->{value})) { - # == 0 + } elsif ($x->{sign} eq '+') { + if ($LIB->_is_zero($x->{value})) { # +1 - 1 => +0 $x->{value} = $LIB->_one(); - $x->{sign} = '-'; # 0 => -1 + $x->{sign} = '-'; } else { - # > 0 $x->{value} = $LIB->_dec($x->{value}); } } - $x->round(@r); + + return $x->round(@r); } #sub bstrcmp { @@ -1589,51 +1769,37 @@ sub badd { # return result as BINT # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x->modify('badd'); - return $upgrade->badd($upgrade->new($x), $upgrade->new($y), @r) if defined $upgrade && - ((!$x->isa($class)) || (!$y->isa($class))); $r[3] = $y; # no push! - # inf and NaN handling + + return $upgrade->badd($x, $y, @r) + if defined($upgrade) && (!$x->isa($class) || !$y->isa($class)); + + # Inf and NaN handling if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/) { # NaN first - return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); - # inf handling + return $x->bnan(@r) if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); + # Inf handling if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/)) { - # +inf++inf or -inf+-inf => same, rest is NaN - return $x if $x->{sign} eq $y->{sign}; - return $x->bnan(); + # +Inf + +Inf or -Inf + -Inf => same, rest is NaN + return $x->round(@r) if $x->{sign} eq $y->{sign}; + return $x->bnan(@r); } - # +-inf + something => +inf - # something +-inf => +-inf - $x->{sign} = $y->{sign}, return $x if $y->{sign} =~ /^[+-]inf$/; - return $x; - } - - my ($sx, $sy) = ($x->{sign}, $y->{sign}); # get signs - - if ($sx eq $sy) { - $x->{value} = $LIB->_add($x->{value}, $y->{value}); # same sign, abs add - } else { - my $a = $LIB->_acmp ($y->{value}, $x->{value}); # absolute compare - if ($a > 0) { - $x->{value} = $LIB->_sub($y->{value}, $x->{value}, 1); # abs sub w/ swap - $x->{sign} = $sy; - } elsif ($a == 0) { - # speedup, if equal, set result to 0 - $x->{value} = $LIB->_zero(); - $x->{sign} = '+'; - } else # a < 0 - { - $x->{value} = $LIB->_sub($x->{value}, $y->{value}); # abs sub + # ±Inf + something => ±Inf + # something + ±Inf => ±Inf + if ($y->{sign} =~ /^[+-]inf$/) { + $x->{sign} = $y->{sign}; } + return $x -> round(@r); } + + ($x->{value}, $x->{sign}) + = $LIB -> _sadd($x->{value}, $x->{sign}, $y->{value}, $y->{sign}); $x->round(@r); } @@ -1642,17 +1808,14 @@ sub bsub { # subtract second arg from first, modify first # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x -> modify('bsub'); - return $upgrade -> new($x) -> bsub($upgrade -> new($y), @r) - if defined $upgrade && (!$x -> isa($class) || !$y -> isa($class)); + return $upgrade -> bsub($x, $y, @r) + if defined($upgrade) && (!$x->isa($class) || !$y->isa($class)); return $x -> round(@r) if $y -> is_zero(); @@ -1665,9 +1828,10 @@ sub bsub { if ($xsign ne $x -> {sign}) { # special case of $x -> bsub($x) results in 0 return $x -> bzero(@r) if $xsign =~ /^[+-]$/; - return $x -> bnan(); # NaN, -inf, +inf + return $x -> bnan(@r); # NaN, -inf, +inf } - $x -> badd($y, @r); # badd does not leave internal zeros + + $x = $x -> badd($y, @r); # badd() does not leave internal zeros $y -> {sign} =~ tr/+-/-+/; # refix $y (does nothing for NaN) $x; # already rounded by badd() or no rounding } @@ -1677,29 +1841,27 @@ sub bmul { # (BINT or num_str, BINT or num_str) return BINT # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x->modify('bmul'); - return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); + return $x->bnan(@r) if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); # inf handling if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/)) { - return $x->bnan() if $x->is_zero() || $y->is_zero(); + return $x->bnan(@r) if $x->is_zero() || $y->is_zero(); # result will always be +-inf: # +inf * +/+inf => +inf, -inf * -/-inf => +inf # +inf * -/-inf => -inf, -inf * +/+inf => -inf - return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/); - return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/); - return $x->binf('-'); + return $x->binf(@r) if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/); + return $x->binf(@r) if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/); + return $x->binf('-', @r); } - return $upgrade->bmul($x, $upgrade->new($y), @r) - if defined $upgrade && !$y->isa($class); + return $upgrade->bmul($x, $y, @r) + if defined($upgrade) && (!$x->isa($class) || !$y->isa($class)); $r[3] = $y; # no push here @@ -1716,60 +1878,143 @@ sub bmuladd { # (BINT or num_str, BINT or num_str, BINT or num_str) return BINT # set up parameters - my ($class, $x, $y, $z, @r) = objectify(3, @_); + my ($class, $x, $y, $z, @r) + = ref($_[0]) && ref($_[0]) eq ref($_[1]) && ref($_[1]) eq ref($_[2]) + ? (ref($_[0]), @_) + : objectify(3, @_); return $x if $x->modify('bmuladd'); - return $x->bnan() if (($x->{sign} eq $nan) || - ($y->{sign} eq $nan) || - ($z->{sign} eq $nan)); + # x, y, and z are finite numbers - # inf handling of x and y - if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/)) { - return $x->bnan() if $x->is_zero() || $y->is_zero(); - # result will always be +-inf: - # +inf * +/+inf => +inf, -inf * -/-inf => +inf - # +inf * -/-inf => -inf, -inf * +/+inf => -inf - return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/); - return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/); - return $x->binf('-'); - } - # inf handling x*y and z - if (($z->{sign} =~ /^[+-]inf$/)) { - # something +-inf => +-inf - $x->{sign} = $z->{sign}, return $x if $z->{sign} =~ /^[+-]inf$/; + if ($x->{sign} =~ /^[+-]$/ && + $y->{sign} =~ /^[+-]$/ && + $z->{sign} =~ /^[+-]$/) + { + return $upgrade->bmuladd($x, $y, $z, @r) + if defined($upgrade) + && (!$x->isa($class) || !$y->isa($class) || !$z->isa($class)); + + # TODO: what if $y and $z have A or P set? + $r[3] = $z; # no push here + + my $zs = $z->{sign}; + my $zv = $z->{value}; + $zv = $LIB -> _copy($zv) if refaddr($x) eq refaddr($z); + + $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; # +1 * +1 or -1 * -1 => + + $x->{value} = $LIB->_mul($x->{value}, $y->{value}); # do actual math + $x->{sign} = '+' if $LIB->_is_zero($x->{value}); # no -0 + + ($x->{value}, $x->{sign}) + = $LIB -> _sadd($x->{value}, $x->{sign}, $zv, $zs); + return $x->round(@r); } - return $upgrade->bmuladd($x, $upgrade->new($y), $upgrade->new($z), @r) - if defined $upgrade && (!$y->isa($class) || !$z->isa($class) || !$x->isa($class)); + # At least one of x, y, and z is a NaN - # TODO: what if $y and $z have A or P set? - $r[3] = $z; # no push here + return $x->bnan(@r) if (($x->{sign} eq $nan) || + ($y->{sign} eq $nan) || + ($z->{sign} eq $nan)); - $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; # +1 * +1 or -1 * -1 => + + # At least one of x, y, and z is an Inf - $x->{value} = $LIB->_mul($x->{value}, $y->{value}); # do actual math - $x->{sign} = '+' if $LIB->_is_zero($x->{value}); # no -0 + if ($x->{sign} eq "-inf") { - my ($sx, $sz) = ( $x->{sign}, $z->{sign} ); # get signs + if ($y -> is_neg()) { # x = -inf, y < 0 + if ($z->{sign} eq "-inf") { + return $x->bnan(@r); + } else { + return $x->binf("+", @r); + } + } elsif ($y -> is_zero()) { # x = -inf, y = 0 + return $x->bnan(@r); + } else { # x = -inf, y > 0 + if ($z->{sign} eq "+inf") { + return $x->bnan(@r); + } else { + return $x->binf("-", @r); + } + } - if ($sx eq $sz) { - $x->{value} = $LIB->_add($x->{value}, $z->{value}); # same sign, abs add - } else { - my $a = $LIB->_acmp ($z->{value}, $x->{value}); # absolute compare - if ($a > 0) { - $x->{value} = $LIB->_sub($z->{value}, $x->{value}, 1); # abs sub w/ swap - $x->{sign} = $sz; - } elsif ($a == 0) { - # speedup, if equal, set result to 0 - $x->{value} = $LIB->_zero(); - $x->{sign} = '+'; - } else # a < 0 - { - $x->{value} = $LIB->_sub($x->{value}, $z->{value}); # abs sub + } elsif ($x->{sign} eq "+inf") { + + if ($y -> is_neg()) { # x = +inf, y < 0 + if ($z->{sign} eq "+inf") { + return $x->bnan(@r); + } else { + return $x->binf("-", @r); + } + } elsif ($y -> is_zero()) { # x = +inf, y = 0 + return $x->bnan(@r); + } else { # x = +inf, y > 0 + if ($z->{sign} eq "-inf") { + return $x->bnan(@r); + } else { + return $x->binf("+", @r); + } + } + + } elsif ($x -> is_neg()) { + + if ($y->{sign} eq "-inf") { # -inf < x < 0, y = -inf + if ($z->{sign} eq "-inf") { + return $x->bnan(@r); + } else { + return $x->binf("+", @r); + } + } elsif ($y->{sign} eq "+inf") { # -inf < x < 0, y = +inf + if ($z->{sign} eq "+inf") { + return $x->bnan(@r); + } else { + return $x->binf("-", @r); + } + } else { # -inf < x < 0, -inf < y < +inf + if ($z->{sign} eq "-inf") { + return $x->binf("-", @r); + } elsif ($z->{sign} eq "+inf") { + return $x->binf("+", @r); + } + } + + } elsif ($x -> is_zero()) { + + if ($y->{sign} eq "-inf") { # x = 0, y = -inf + return $x->bnan(@r); + } elsif ($y->{sign} eq "+inf") { # x = 0, y = +inf + return $x->bnan(@r); + } else { # x = 0, -inf < y < +inf + if ($z->{sign} eq "-inf") { + return $x->binf("-", @r); + } elsif ($z->{sign} eq "+inf") { + return $x->binf("+", @r); + } + } + + } elsif ($x -> is_pos()) { + + if ($y->{sign} eq "-inf") { # 0 < x < +inf, y = -inf + if ($z->{sign} eq "+inf") { + return $x->bnan(@r); + } else { + return $x->binf("-", @r); + } + } elsif ($y->{sign} eq "+inf") { # 0 < x < +inf, y = +inf + if ($z->{sign} eq "-inf") { + return $x->bnan(@r); + } else { + return $x->binf("+", @r); + } + } else { # 0 < x < +inf, -inf < y < +inf + if ($z->{sign} eq "-inf") { + return $x->binf("-", @r); + } elsif ($z->{sign} eq "+inf") { + return $x->binf("+", @r); + } } } - $x->round(@r); + + die; } sub bdiv { @@ -1778,12 +2023,9 @@ sub bdiv { # sign as the divisor. # Set up parameters. - my ($class, $x, $y, @r) = (ref($_[0]), @_); - - # objectify() is costly, so avoid it if we can. - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x -> modify('bdiv'); @@ -1793,7 +2035,8 @@ sub bdiv { # modulo/remainder. if ($x -> is_nan() || $y -> is_nan()) { - return $wantarray ? ($x -> bnan(), $class -> bnan()) : $x -> bnan(); + return $wantarray ? ($x -> bnan(@r), $class -> bnan(@r)) + : $x -> bnan(@r); } # Divide by zero and modulo zero. @@ -1816,12 +2059,12 @@ sub bdiv { if ($y -> is_zero()) { my $rem; if ($wantarray) { - $rem = $x -> copy(); + $rem = $x -> copy() -> round(@r); } if ($x -> is_zero()) { - $x -> bnan(); + $x = $x -> bnan(@r); } else { - $x -> binf($x -> {sign}); + $x = $x -> binf($x -> {sign}, @r); } return $wantarray ? ($x, $rem) : $x; } @@ -1842,12 +2085,12 @@ sub bdiv { if ($x -> is_inf()) { my $rem; - $rem = $class -> bnan() if $wantarray; + $rem = $class -> bnan(@r) if $wantarray; if ($y -> is_inf()) { - $x -> bnan(); + $x = $x -> bnan(@r); } else { my $sign = $x -> bcmp(0) == $y -> bcmp(0) ? '+' : '-'; - $x -> binf($sign); + $x = $x -> binf($sign, @r); } return $wantarray ? ($x, $rem) : $x; } @@ -1868,11 +2111,11 @@ sub bdiv { if ($y -> is_inf()) { my $rem; if ($x -> is_zero() || $x -> bcmp(0) == $y -> bcmp(0)) { - $rem = $x -> copy() if $wantarray; - $x -> bzero(); + $rem = $x -> copy() -> round(@r) if $wantarray; + $x = $x -> bzero(@r); } else { - $rem = $class -> binf($y -> {sign}) if $wantarray; - $x -> bone('-'); + $rem = $class -> binf($y -> {sign}, @r) if $wantarray; + $x = $x -> bone('-', @r); } return $wantarray ? ($x, $rem) : $x; } @@ -1880,8 +2123,10 @@ sub bdiv { # At this point, both the numerator and denominator are finite numbers, and # the denominator (divisor) is non-zero. - return $upgrade -> bdiv($upgrade -> new($x), $upgrade -> new($y), @r) - if defined $upgrade; + # Division might return a non-integer result, so upgrade unconditionally, if + # upgrading is enabled. + + return $upgrade -> bdiv($x, $y, @r) if defined $upgrade; $r[3] = $y; # no push! @@ -1900,7 +2145,7 @@ sub bdiv { $y -> {sign} = $ysign; # Re-insert the original sign. if ($same) { - $x -> bone(); + $x = $x -> bone(); } else { ($x -> {value}, $rem -> {value}) = $LIB -> _div($x -> {value}, $y -> {value}); @@ -1916,16 +2161,16 @@ sub bdiv { $x -> {sign} = '+'; } else { if ($xsign eq '+') { - $x -> badd(1); + $x = $x -> badd(1); } else { - $x -> bsub(1); + $x = $x -> bsub(1); } $x -> {sign} = '-'; } } } - $x -> round(@r); + $x = $x -> round(@r); if ($wantarray) { unless ($LIB -> _is_zero($rem -> {value})) { @@ -1936,7 +2181,7 @@ sub bdiv { } $rem -> {_a} = $x -> {_a}; $rem -> {_p} = $x -> {_p}; - $rem -> round(@r); + $rem = $rem -> round(@r); return ($x, $rem); } @@ -1951,12 +2196,9 @@ sub btdiv { # and $q * $y + $r = $x. # Set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - - # objectify is costly, so avoid it if we can. - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x -> modify('btdiv'); @@ -1966,7 +2208,8 @@ sub btdiv { # modulo/remainder. if ($x -> is_nan() || $y -> is_nan()) { - return $wantarray ? ($x -> bnan(), $class -> bnan()) : $x -> bnan(); + return $wantarray ? ($x -> bnan(@r), $class -> bnan(@r)) + : $x -> bnan(@r); } # Divide by zero and modulo zero. @@ -1989,12 +2232,12 @@ sub btdiv { if ($y -> is_zero()) { my $rem; if ($wantarray) { - $rem = $x -> copy(); + $rem = $x -> copy(@r); } if ($x -> is_zero()) { - $x -> bnan(); + $x = $x -> bnan(@r); } else { - $x -> binf($x -> {sign}); + $x = $x -> binf($x -> {sign}, @r); } return $wantarray ? ($x, $rem) : $x; } @@ -2015,12 +2258,12 @@ sub btdiv { if ($x -> is_inf()) { my $rem; - $rem = $class -> bnan() if $wantarray; + $rem = $class -> bnan(@r) if $wantarray; if ($y -> is_inf()) { - $x -> bnan(); + $x = $x -> bnan(@r); } else { my $sign = $x -> bcmp(0) == $y -> bcmp(0) ? '+' : '-'; - $x -> binf($sign); + $x = $x -> binf($sign,@r ); } return $wantarray ? ($x, $rem) : $x; } @@ -2040,13 +2283,15 @@ sub btdiv { if ($y -> is_inf()) { my $rem; - $rem = $x -> copy() if $wantarray; - $x -> bzero(); + $rem = $x -> copy() -> round(@r) if $wantarray; + $x = $x -> bzero(@r); return $wantarray ? ($x, $rem) : $x; } - return $upgrade -> btdiv($upgrade -> new($x), $upgrade -> new($y), @r) - if defined $upgrade; + # Division might return a non-integer result, so upgrade unconditionally, if + # upgrading is enabled. + + return $upgrade -> btdiv($x, $y, @r) if defined $upgrade; $r[3] = $y; # no push! @@ -2065,14 +2310,14 @@ sub btdiv { $y -> {sign} = $ysign; # Re-insert the original sign. if ($same) { - $x -> bone(); + $x = $x -> bone(@r); } else { ($x -> {value}, $rem -> {value}) = $LIB -> _div($x -> {value}, $y -> {value}); $x -> {sign} = $xsign eq $ysign ? '+' : '-'; $x -> {sign} = '+' if $LIB -> _is_zero($x -> {value}); - $x -> round(@r); + $x = $x -> round(@r); } if (wantarray) { @@ -2080,7 +2325,7 @@ sub btdiv { $rem -> {sign} = '+' if $LIB -> _is_zero($rem -> {value}); $rem -> {_a} = $x -> {_a}; $rem -> {_p} = $x -> {_p}; - $rem -> round(@r); + $rem = $rem -> round(@r); return ($x, $rem); } @@ -2091,44 +2336,45 @@ sub bmod { # This is the remainder after floored division. # Set up parameters. - my ($class, $x, $y, @r) = (ref($_[0]), @_); - - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x -> modify('bmod'); + $r[3] = $y; # no push! # At least one argument is NaN. if ($x -> is_nan() || $y -> is_nan()) { - return $x -> bnan(); + return $x -> bnan(@r); } # Modulo zero. See documentation for bdiv(). if ($y -> is_zero()) { - return $x; + return $x -> round(@r); } # Numerator (dividend) is +/-inf. if ($x -> is_inf()) { - return $x -> bnan(); + return $x -> bnan(@r); } # Denominator (divisor) is +/-inf. if ($y -> is_inf()) { if ($x -> is_zero() || $x -> bcmp(0) == $y -> bcmp(0)) { - return $x; + return $x -> round(@r); } else { - return $x -> binf($y -> sign()); + return $x -> binf($y -> sign(), @r); } } + return $upgrade -> bmod($x, $y, @r) + if defined($upgrade) && (!$x -> isa($class) || !$y -> isa($class)); + # Calc new sign and in case $y == +/- 1, return $x. $x -> {value} = $LIB -> _mod($x -> {value}, $y -> {value}); @@ -2147,41 +2393,38 @@ sub btmod { # Remainder after truncated division. # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x -> modify('btmod'); # At least one argument is NaN. if ($x -> is_nan() || $y -> is_nan()) { - return $x -> bnan(); + return $x -> bnan(@r); } # Modulo zero. See documentation for btdiv(). if ($y -> is_zero()) { - return $x; + return $x -> round(@r); } # Numerator (dividend) is +/-inf. if ($x -> is_inf()) { - return $x -> bnan(); + return $x -> bnan(@r); } # Denominator (divisor) is +/-inf. if ($y -> is_inf()) { - return $x; + return $x -> round(@r); } - return $upgrade -> btmod($upgrade -> new($x), $upgrade -> new($y), @r) - if defined $upgrade; + return $upgrade -> btmod($x, $y, @r) + if defined($upgrade) && (!$x -> isa($class) || !$y -> isa($class)); $r[3] = $y; # no push! @@ -2192,7 +2435,6 @@ sub btmod { $x -> {sign} = $xsign; $x -> {sign} = '+' if $LIB -> _is_zero($x -> {value}); $x -> round(@r); - return $x; } sub bmodinv { @@ -2208,28 +2450,29 @@ sub bmodinv { # If no modular multiplicative inverse exists, NaN is returned. # set up parameters - my ($class, $x, $y, @r) = (undef, @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); return $x if $x->modify('bmodinv'); # Return NaN if one or both arguments is +inf, -inf, or nan. - return $x->bnan() if ($y->{sign} !~ /^[+-]$/ || - $x->{sign} !~ /^[+-]$/); + return $x->bnan(@r) if ($y->{sign} !~ /^[+-]$/ || + $x->{sign} !~ /^[+-]$/); # Return NaN if $y is zero; 1 % 0 makes no sense. - return $x->bnan() if $y->is_zero(); + return $x->bnan(@r) if $y->is_zero(); # Return 0 in the trivial case. $x % 1 or $x % -1 is zero for all finite # integers $x. - return $x->bzero() if ($y->is_one() || - $y->is_one('-')); + return $x->bzero(@r) if ($y->is_one('+') || + $y->is_one('-')); + + return $upgrade -> bmodinv($x, $y, @r) + if defined($upgrade) && (!$x -> isa($class) || !$y -> isa($class)); # Return NaN if $x = 0, or $x modulo $y is zero. The only valid case when # $x = 0 is when $y = 1 or $y = -1, but that was covered above. @@ -2240,14 +2483,14 @@ sub bmodinv { # $y = 7, the values fed to _modinv() are $x = 2 (= -5 % 7) and $y = 7. # The value if $x is affected only when $x and $y have opposite signs. - $x->bmod($y); - return $x->bnan() if $x->is_zero(); + $x = $x->bmod($y); + return $x->bnan(@r) if $x->is_zero(); # Compute the modular multiplicative inverse of the absolute values. We'll # correct for the signs of $x and $y later. Return NaN if no GCD is found. ($x->{value}, $x->{sign}) = $LIB->_modinv($x->{value}, $y->{value}); - return $x->bnan() if !defined $x->{value}; + return $x->bnan(@r) if !defined($x->{value}); # Library inconsistency workaround: _modinv() in Math::BigInt::GMP versions # <= 1.32 return undef rather than a "+" for the sign. @@ -2266,20 +2509,23 @@ sub bmodinv { # inverse modulo. The net effect is that we must swap the sign of the # result if $y is negative. - $x -> bneg() if $y->{sign} eq '-'; + $x = $x -> bneg() if $y->{sign} eq '-'; # Compute $x modulo $y again after correcting the sign. - $x -> bmod($y) if $x->{sign} ne $y->{sign}; + $x = $x -> bmod($y) if $x->{sign} ne $y->{sign}; - return $x; + $x -> round(@r); } sub bmodpow { - # Modular exponentiation. Raises a very large number to a very large exponent - # in a given very large modulus quickly, thanks to binary exponentiation. - # Supports negative exponents. - my ($class, $num, $exp, $mod, @r) = objectify(3, @_); + # Modular exponentiation. Raises a very large number to a very large + # exponent in a given very large modulus quickly, thanks to binary + # exponentiation. Supports negative exponents. + my ($class, $num, $exp, $mod, @r) + = ref($_[0]) && ref($_[0]) eq ref($_[1]) && ref($_[1]) eq ref($_[2]) + ? (ref($_[0]), @_) + : objectify(3, @_); return $num if $num->modify('bmodpow'); @@ -2288,25 +2534,30 @@ sub bmodpow { # # b^(-e) (mod m) = d^e (mod m) where b*d = 1 (mod m) - $num->bmodinv($mod) if ($exp->{sign} eq '-'); + $num = $num -> bmodinv($mod) if ($exp->{sign} eq '-'); - # Check for valid input. All operands must be finite, and the modulus must be - # non-zero. + # Check for valid input. All operands must be finite, and the modulus must + # be non-zero. - return $num->bnan() if ($num->{sign} =~ /NaN|inf/ || # NaN, -inf, +inf - $exp->{sign} =~ /NaN|inf/ || # NaN, -inf, +inf - $mod->{sign} =~ /NaN|inf/); # NaN, -inf, +inf + return $num->bnan(@r) if ($num->{sign} =~ /NaN|inf/ || # NaN, -inf, +inf + $exp->{sign} =~ /NaN|inf/ || # NaN, -inf, +inf + $mod->{sign} =~ /NaN|inf/); # NaN, -inf, +inf # Modulo zero. See documentation for Math::BigInt's bmod() method. if ($mod -> is_zero()) { if ($num -> is_zero()) { - return $class -> bnan(); + return $class -> bnan(@r); } else { - return $num -> copy(); + return $num -> copy(@r); } } + return $upgrade -> bmodinv($num, $exp, $mod, @r) + if defined($upgrade) && (!$num -> isa($class) || + !$exp -> isa($class) || + !$mod -> ($class)); + # Compute 'a (mod m)', ignoring the signs on 'a' and 'm'. If the resulting # value is zero, the output is also zero, regardless of the signs on 'a' and # 'm'. @@ -2379,53 +2630,67 @@ sub bpow { # modifies first argument # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); - return $x if $x->modify('bpow'); + return $x if $x -> modify('bpow'); # $x and/or $y is a NaN - return $x->bnan() if $x->is_nan() || $y->is_nan(); + return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); # $x and/or $y is a +/-Inf - if ($x->is_inf("-")) { - return $x->bzero() if $y->is_negative(); - return $x->bnan() if $y->is_zero(); - return $x if $y->is_odd(); - return $x->bneg(); - } elsif ($x->is_inf("+")) { - return $x->bzero() if $y->is_negative(); - return $x->bnan() if $y->is_zero(); - return $x; - } elsif ($y->is_inf("-")) { - return $x->bnan() if $x -> is_one("-"); - return $x->binf("+") if $x -> is_zero(); - return $x->bone() if $x -> is_one("+"); - return $x->bzero(); - } elsif ($y->is_inf("+")) { - return $x->bnan() if $x -> is_one("-"); - return $x->bzero() if $x -> is_zero(); - return $x->bone() if $x -> is_one("+"); - return $x->binf("+"); + if ($x -> is_inf("-")) { + return $x -> bzero(@r) if $y -> is_negative(); + return $x -> bnan(@r) if $y -> is_zero(); + return $x -> round(@r) if $y -> is_odd(); + return $x -> bneg(@r); + } elsif ($x -> is_inf("+")) { + return $x -> bzero(@r) if $y -> is_negative(); + return $x -> bnan(@r) if $y -> is_zero(); + return $x -> round(@r); + } elsif ($y -> is_inf("-")) { + return $x -> bnan(@r) if $x -> is_one("-"); + return $x -> binf("+", @r) if $x -> is_zero(); + return $x -> bone(@r) if $x -> is_one("+"); + return $x -> bzero(@r); + } elsif ($y -> is_inf("+")) { + return $x -> bnan(@r) if $x -> is_one("-"); + return $x -> bzero(@r) if $x -> is_zero(); + return $x -> bone(@r) if $x -> is_one("+"); + return $x -> binf("+", @r); + } + + if ($x -> is_zero()) { + return $x -> bone(@r) if $y -> is_zero(); + return $x -> binf(@r) if $y -> is_negative(); + return $x -> round(@r); } - return $upgrade->bpow($upgrade->new($x), $y, @r) - if defined $upgrade && (!$y->isa($class) || $y->{sign} eq '-'); + if ($x -> is_one("+")) { + return $x -> round(@r); + } - $r[3] = $y; # no push! + if ($x -> is_one("-")) { + return $x -> round(@r) if $y -> is_odd(); + return $x -> bneg(@r); + } - # 0 ** -y => ( 1 / (0 ** y)) => 1 / 0 => +inf - return $x->binf() if $y->is_negative() && $x->is_zero(); + return $upgrade -> bpow($x, $y, @r) if defined $upgrade; - # 1 ** -y => 1 / (1 ** |y|) - return $x->bzero() if $y->is_negative() && !$LIB->_is_one($x->{value}); + # We don't support finite non-integers, so return zero. The reason for + # returning zero, not NaN, is that all output is in the open interval (0,1), + # and truncating that to integer gives zero. - $x->{value} = $LIB->_pow($x->{value}, $y->{value}); - $x->{sign} = $x->is_negative() && $y->is_odd() ? '-' : '+'; - $x->round(@r); + if ($y->{sign} eq '-' || !$y -> isa($class)) { + return $x -> bzero(@r); + } + + $r[3] = $y; # no push! + + $x->{value} = $LIB -> _pow($x->{value}, $y->{value}); + $x->{sign} = $x -> is_negative() && $y -> is_odd() ? '-' : '+'; + $x -> round(@r); } sub blog { @@ -2438,12 +2703,12 @@ sub blog { # Don't objectify the base, since an undefined base, as in $x->blog() or # $x->blog(undef) signals that the base is Euler's number. - if (!ref($_[0]) && $_[0] =~ /^[A-Za-z]|::/) { + if (!ref($_[0]) && $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i) { # E.g., Math::BigInt->blog(256, 2) ($class, $x, $base, @r) = defined $_[2] ? objectify(2, @_) : objectify(1, @_); } else { - # E.g., Math::BigInt::blog(256, 2) or $x->blog(2) + # E.g., $x->blog(2) or the deprecated Math::BigInt::blog(256, 2) ($class, $x, $base, @r) = defined $_[1] ? objectify(2, @_) : objectify(1, @_); } @@ -2453,80 +2718,70 @@ sub blog { # Handle all exception cases and all trivial cases. I have used Wolfram # Alpha (http://www.wolframalpha.com) as the reference for these cases. - return $x -> bnan() if $x -> is_nan(); + return $x -> bnan(@r) if $x -> is_nan(); if (defined $base) { $base = $class -> new($base) unless ref $base; if ($base -> is_nan() || $base -> is_one()) { - return $x -> bnan(); + return $x -> bnan(@r); } elsif ($base -> is_inf() || $base -> is_zero()) { - return $x -> bnan() if $x -> is_inf() || $x -> is_zero(); - return $x -> bzero(); - } elsif ($base -> is_negative()) { # -inf < base < 0 - return $x -> bzero() if $x -> is_one(); # x = 1 - return $x -> bone() if $x == $base; # x = base - return $x -> bnan(); # otherwise + return $x -> bnan(@r) if $x -> is_inf() || $x -> is_zero(); + return $x -> bzero(@r); + } elsif ($base -> is_negative()) { # -inf < base < 0 + return $x -> bzero(@r) if $x -> is_one(); # x = 1 + return $x -> bone(@r) if $x == $base; # x = base + return $x -> bnan(@r); # otherwise } - return $x -> bone() if $x == $base; # 0 < base && 0 < x < inf + return $x -> bone(@r) if $x == $base; # 0 < base && 0 < x < inf } # We now know that the base is either undefined or >= 2 and finite. - return $x -> binf('+') if $x -> is_inf(); # x = +/-inf - return $x -> bnan() if $x -> is_neg(); # -inf < x < 0 - return $x -> bzero() if $x -> is_one(); # x = 1 - return $x -> binf('-') if $x -> is_zero(); # x = 0 + return $x -> binf('+', @r) if $x -> is_inf(); # x = +/-inf + return $x -> bnan(@r) if $x -> is_neg(); # -inf < x < 0 + return $x -> bzero(@r) if $x -> is_one(); # x = 1 + return $x -> binf('-', @r) if $x -> is_zero(); # x = 0 # At this point we are done handling all exception cases and trivial cases. - return $upgrade -> blog($upgrade -> new($x), $base, @r) if defined $upgrade; + return $upgrade -> blog($x, $base, @r) if defined $upgrade; # fix for bug #24969: # the default base is e (Euler's number) which is not an integer if (!defined $base) { require Math::BigFloat; - my $u = Math::BigFloat->blog(Math::BigFloat->new($x))->as_int(); + my $u = Math::BigFloat->blog($x)->as_int(); # modify $x in place $x->{value} = $u->{value}; $x->{sign} = $u->{sign}; - return $x; + return $x -> round(@r); } my ($rc) = $LIB->_log_int($x->{value}, $base->{value}); - return $x->bnan() unless defined $rc; # not possible to take log? + return $x->bnan(@r) unless defined $rc; # not possible to take log? $x->{value} = $rc; - $x->round(@r); + $x = $x -> round(@r); } sub bexp { # Calculate e ** $x (Euler's number to the power of X), truncated to # an integer value. my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + return $x if $x->modify('bexp'); # inf, -inf, NaN, <0 => NaN - return $x->bnan() if $x->{sign} eq 'NaN'; - return $x->bone() if $x->is_zero(); - return $x if $x->{sign} eq '+inf'; - return $x->bzero() if $x->{sign} eq '-inf'; + return $x -> bnan(@r) if $x->{sign} eq 'NaN'; + return $x -> bone(@r) if $x->is_zero(); + return $x -> round(@r) if $x->{sign} eq '+inf'; + return $x -> bzero(@r) if $x->{sign} eq '-inf'; - my $u; - { - # run through Math::BigFloat unless told otherwise - require Math::BigFloat unless defined $upgrade; - local $upgrade = 'Math::BigFloat' unless defined $upgrade; - # calculate result, truncate it to integer - $u = $upgrade->bexp($upgrade->new($x), @r); - } + return $upgrade -> bexp($x, @r) if defined $upgrade; - if (defined $upgrade) { - $x = $u; - } else { - $u = $u->as_int(); - # modify $x in place - $x->{value} = $u->{value}; - $x->round(@r); - } + require Math::BigFloat; + my $tmp = Math::BigFloat -> bexp($x, @r) -> as_int(); + $x->{value} = $tmp->{value}; + return $x -> round(@r); } sub bnok { @@ -2534,49 +2789,51 @@ sub bnok { # integer. # Set up parameters. - my ($self, $n, $k, @r) = (ref($_[0]), @_); + my ($class, $n, $k, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) + : objectify(2, @_); - # Objectify is costly, so avoid it. - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($self, $n, $k, @r) = objectify(2, @_); - } + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; return $n if $n->modify('bnok'); # All cases where at least one argument is NaN. - return $n->bnan() if $n->{sign} eq 'NaN' || $k->{sign} eq 'NaN'; + return $n->bnan(@r) if $n->{sign} eq 'NaN' || $k->{sign} eq 'NaN'; # All cases where at least one argument is +/-inf. if ($n -> is_inf()) { if ($k -> is_inf()) { # bnok(+/-inf,+/-inf) - return $n -> bnan(); + return $n -> bnan(@r); } elsif ($k -> is_neg()) { # bnok(+/-inf,k), k < 0 - return $n -> bzero(); + return $n -> bzero(@r); } elsif ($k -> is_zero()) { # bnok(+/-inf,k), k = 0 - return $n -> bone(); + return $n -> bone(@r); } else { - if ($n -> is_inf("+")) { # bnok(+inf,k), 0 < k < +inf + if ($n -> is_inf("+", @r)) { # bnok(+inf,k), 0 < k < +inf return $n -> binf("+"); } else { # bnok(-inf,k), k > 0 my $sign = $k -> is_even() ? "+" : "-"; - return $n -> binf($sign); + return $n -> binf($sign, @r); } } } elsif ($k -> is_inf()) { # bnok(n,+/-inf), -inf <= n <= inf - return $n -> bnan(); + return $n -> bnan(@r); } # At this point, both n and k are real numbers. + return $upgrade -> bnok($n, $k, @r) + if defined($upgrade) && (!$n -> isa($class) || !$k -> isa($class)); + my $sign = 1; if ($n >= 0) { if ($k < 0 || $k > $n) { - return $n -> bzero(); + return $n -> bzero(@r); } } else { @@ -2585,7 +2842,7 @@ sub bnok { # n < 0 and k >= 0: bnok(n,k) = (-1)^k * bnok(-n+k-1,k) $sign = (-1) ** $k; - $n -> bneg() -> badd($k) -> bdec(); + $n = $n -> bneg() -> badd($k) -> bdec(); } elsif ($k <= $n) { @@ -2593,22 +2850,22 @@ sub bnok { $sign = (-1) ** ($n - $k); my $x0 = $n -> copy(); - $n -> bone() -> badd($k) -> bneg(); + $n = $n -> bone() -> badd($k) -> bneg(); $k = $k -> copy(); - $k -> bneg() -> badd($x0); + $k = $k -> bneg() -> badd($x0); } else { # n < 0 and n < k < 0: - return $n -> bzero(); + return $n -> bzero(@r); } } $n->{value} = $LIB->_nok($n->{value}, $k->{value}); - $n -> bneg() if $sign == -1; + $n = $n -> bneg() if $sign == -1; - $n->round(@r); + $n -> round(@r); } sub buparrow { @@ -2721,9 +2978,9 @@ sub ackermann { } elsif ($m == $three) { $n = $class -> bone() -> blsft($n + $three) -> bsub($three); } elsif ($m == $two) { - $n -> bmul($two) -> badd($three); + $n = $n -> bmul($two) -> badd($three); } elsif ($m >= 0) { - $n -> badd($m) -> binc(); + $n = $n -> badd($m) -> binc(); } else { die "negative m!"; } @@ -2732,109 +2989,102 @@ sub ackermann { } sub bsin { - # Calculate sinus(x) to N digits. Unless upgrading is in effect, returns the + # Calculate sin(x) to N digits. Unless upgrading is in effect, returns the # result truncated to an integer. - my ($class, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('bsin'); - return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN + return $x->bnan(@r) if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN + return $x->bzero(@r) if $x->is_zero(); - return $upgrade->new($x)->bsin(@r) if defined $upgrade; + return $upgrade -> bsin($x, @r) if defined $upgrade; require Math::BigFloat; # calculate the result and truncate it to integer my $t = Math::BigFloat->new($x)->bsin(@r)->as_int(); - $x->bone() if $t->is_one(); - $x->bzero() if $t->is_zero(); + $x = $x->bone(@r) if $t->is_one(); + $x = $x->bzero(@r) if $t->is_zero(); $x->round(@r); } sub bcos { - # Calculate cosinus(x) to N digits. Unless upgrading is in effect, returns the + # Calculate cos(x) to N digits. Unless upgrading is in effect, returns the # result truncated to an integer. - my ($class, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('bcos'); - return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN + return $x->bnan(@r) if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN + return $x->bone(@r) if $x->is_zero(); - return $upgrade->new($x)->bcos(@r) if defined $upgrade; + return $upgrade -> bcos($x, @r) if defined $upgrade; require Math::BigFloat; - # calculate the result and truncate it to integer - my $t = Math::BigFloat->new($x)->bcos(@r)->as_int(); - - $x->bone() if $t->is_one(); - $x->bzero() if $t->is_zero(); - $x->round(@r); + my $tmp = Math::BigFloat -> bcos($x, @r) -> as_int(); + $x->{value} = $tmp->{value}; + return $x -> round(@r); } sub batan { - # Calculate arcus tangens of x to N digits. Unless upgrading is in effect, returns the - # result truncated to an integer. - my ($class, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + # Calculate arctan(x) to N digits. Unless upgrading is in effect, returns + # the result truncated to an integer. + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('batan'); - return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN + return $x -> bnan(@r) if $x -> is_nan(); + return $x -> bzero(@r) if $x -> is_zero(); - return $upgrade->new($x)->batan(@r) if defined $upgrade; + return $upgrade -> batan($x, @r) if defined $upgrade; - # calculate the result and truncate it to integer - my $tmp = Math::BigFloat->new($x)->batan(@r); + return $x -> bone("+", @r) if $x -> bgt("1"); + return $x -> bone("-", @r) if $x -> blt("-1"); - $x->{value} = $LIB->_new($tmp->as_int()->bstr()); - $x->round(@r); + $x -> bzero(@r); } sub batan2 { # calculate arcus tangens of ($y/$x) - # set up parameters - my ($class, $y, $x, @r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $y, $x, @r) = objectify(2, @_); - } + my ($class, $y, $x, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) : objectify(2, @_); return $y if $y->modify('batan2'); return $y->bnan() if ($y->{sign} eq $nan) || ($x->{sign} eq $nan); + return $upgrade->batan2($y, $x, @r) if defined $upgrade; + # Y X # != 0 -inf result is +- pi if ($x->is_inf() || $y->is_inf()) { - # upgrade to Math::BigFloat etc. - return $upgrade->new($y)->batan2($upgrade->new($x), @r) if defined $upgrade; if ($y->is_inf()) { if ($x->{sign} eq '-inf') { # calculate 3 pi/4 => 2.3.. => 2 - $y->bone(substr($y->{sign}, 0, 1)); - $y->bmul($class->new(2)); + $y = $y->bone(substr($y->{sign}, 0, 1)); + $y = $y->bmul($class->new(2)); } elsif ($x->{sign} eq '+inf') { # calculate pi/4 => 0.7 => 0 - $y->bzero(); + $y = $y->bzero(); } else { # calculate pi/2 => 1.5 => 1 - $y->bone(substr($y->{sign}, 0, 1)); + $y = $y->bone(substr($y->{sign}, 0, 1)); } } else { if ($x->{sign} eq '+inf') { # calculate pi/4 => 0.7 => 0 - $y->bzero(); + $y = $y->bzero(); } else { # PI => 3.1415.. => 3 - $y->bone(substr($y->{sign}, 0, 1)); - $y->bmul($class->new(3)); + $y = $y->bone(substr($y->{sign}, 0, 1)); + $y = $y->bmul($class->new(3)); } } return $y; } - return $upgrade->new($y)->batan2($upgrade->new($x), @r) if defined $upgrade; - require Math::BigFloat; my $r = Math::BigFloat->new($y) ->batan2(Math::BigFloat->new($x), @r) @@ -2843,17 +3093,17 @@ sub batan2 { $x->{value} = $r->{value}; $x->{sign} = $r->{sign}; - $x; + $x->round(@r); } sub bsqrt { # calculate square root of $x - my ($class, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('bsqrt'); - return $x->bnan() if $x->{sign} !~ /^\+/; # -x or -inf or NaN => NaN - return $x if $x->{sign} eq '+inf'; # sqrt(+inf) == inf + return $x->bnan(@r) if $x->{sign} !~ /^\+/; # -x or -inf or NaN => NaN + return $x->round(@r) if $x->{sign} eq '+inf'; # sqrt(+inf) == inf return $upgrade->bsqrt($x, @r) if defined $upgrade; @@ -2865,25 +3115,22 @@ sub broot { # calculate $y'th root of $x # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - $y = $class->new(2) unless defined $y; + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) : objectify(2, @_); - # objectify is costly, so avoid it - if ((!ref($x)) || (ref($x) ne ref($y))) { - ($class, $x, $y, @r) = objectify(2, $class || $class, @_); - } + $y = $class->new(2) unless defined $y; return $x if $x->modify('broot'); # NaN handling: $x ** 1/0, x or y NaN, or y inf/-inf or y == 0 - return $x->bnan() if $x->{sign} !~ /^\+/ || $y->is_zero() || - $y->{sign} !~ /^\+$/; + return $x->bnan(@r) if $x->{sign} !~ /^\+/ || $y->is_zero() || + $y->{sign} !~ /^\+$/; return $x->round(@r) if $x->is_zero() || $x->is_one() || $x->is_inf() || $y->is_one(); - return $upgrade->new($x)->broot($upgrade->new($y), @r) if defined $upgrade; + return $upgrade->broot($x, $y, @r) if defined $upgrade; $x->{value} = $LIB->_root($x->{value}, $y->{value}); $x->round(@r); @@ -2892,10 +3139,14 @@ sub broot { sub bfac { # (BINT or num_str, BINT or num_str) return BINT # compute factorial number from $x, modify $x in place - my ($class, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('bfac') || $x->{sign} eq '+inf'; # inf => inf - return $x->bnan() if $x->{sign} ne '+'; # NaN, <0 etc => NaN + + return $x->bnan(@r) if $x->{sign} ne '+'; # NaN, <0 => NaN + + return $upgrade -> bfac($x, @r) + if defined($upgrade) && !$x -> isa($class); $x->{value} = $LIB->_fac($x->{value}); $x->round(@r); @@ -2903,10 +3154,15 @@ sub bfac { sub bdfac { # compute double factorial, modify $x in place - my ($class, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('bdfac') || $x->{sign} eq '+inf'; # inf => inf - return $x->bnan() if $x->{sign} ne '+'; # NaN, <0 etc => NaN + + return $x->bnan(@r) if $x->is_nan() || $x <= -2; + return $x->bone(@r) if $x <= 1; + + return $upgrade -> bdfac($x, @r) + if defined($upgrade) && !$x -> isa($class); croak("bdfac() requires a newer version of the $LIB library.") unless $LIB->can('_dfac'); @@ -2915,21 +3171,69 @@ sub bdfac { $x->round(@r); } +sub btfac { + # compute triple factorial, modify $x in place + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + return $x if $x->modify('btfac') || $x->{sign} eq '+inf'; # inf => inf + + return $x->bnan(@r) if $x->is_nan(); + + return $upgrade -> btfac($x, @r) if defined($upgrade) && !$x -> isa($class); + + my $k = $class -> new("3"); + return $x->bnan(@r) if $x <= -$k; + + my $one = $class -> bone(); + return $x->bone(@r) if $x <= $one; + + my $f = $x -> copy(); + while ($f -> bsub($k) > $one) { + $x = $x -> bmul($f); + } + $x->round(@r); +} + +sub bmfac { + # compute multi-factorial + + my ($class, $x, $k, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) : objectify(2, @_); + + return $x if $x->modify('bmfac') || $x->{sign} eq '+inf'; + return $x->bnan(@r) if $x->is_nan() || $k->is_nan() || $k < 1 || $x <= -$k; + + return $upgrade -> bmfac($x, $k, @r) + if defined($upgrade) && !$x -> isa($class); + + my $one = $class -> bone(); + return $x->bone(@r) if $x <= $one; + + my $f = $x -> copy(); + while ($f -> bsub($k) > $one) { + $x = $x -> bmul($f); + } + $x->round(@r); +} + sub bfib { # compute Fibonacci number(s) - my ($class, $x, @r) = objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); croak("bfib() requires a newer version of the $LIB library.") unless $LIB->can('_fib'); return $x if $x->modify('bfib'); + return $upgrade -> bfib($x, @r) + if defined($upgrade) && !$x -> isa($class); + # List context. if (wantarray) { - return () if $x -> is_nan(); + return () if $x -> is_nan(); croak("bfib() can't return an infinitely long list of numbers") - if $x -> is_inf(); + if $x -> is_inf(); # Use the backend library to compute the first $x Fibonacci numbers. @@ -2939,7 +3243,7 @@ sub bfib { # invocand. for (my $i = 0 ; $i < $#values ; ++ $i) { - my $fib = $class -> bzero(); + my $fib = $class -> bzero(); $fib -> {value} = $values[$i]; $values[$i] = $fib; } @@ -2973,13 +3277,16 @@ sub bfib { sub blucas { # compute Lucas number(s) - my ($class, $x, @r) = objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); croak("blucas() requires a newer version of the $LIB library.") unless $LIB->can('_lucas'); return $x if $x->modify('blucas'); + return $upgrade -> blucas($x, @r) + if defined($upgrade) && !$x -> isa($class); + # List context. if (wantarray) { @@ -3050,8 +3357,19 @@ sub blsft { return $x -> bnan() if ($x -> {sign} !~ /^[+-]$/ || $y -> {sign} !~ /^[+-]$/); return $x -> round(@r) if $y -> is_zero(); + return $x -> bzero(@r) if $x -> is_zero(); # 0 => 0 + + $b = 2 if !defined $b; + return $x -> bnan(@r) if $b <= 0 || $y -> {sign} eq '-'; + $b = $class -> new($b) unless defined(blessed($b)); - $b = defined($b) ? $b -> numify() : 2; + #return $upgrade -> blsft($x, $y, $b, @r) + # if defined($upgrade) && (!$x -> isa($class) || + # !$y -> isa($class) || + # !$b -> isa($class)); + + # shift by a negative amount? + #return $x -> brsft($y -> copy() -> babs(), $b) if $y -> {sign} =~ /^-/; # 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, @@ -3060,6 +3378,8 @@ sub blsft { my $uintmax = ~0; croak("Base is too large.") if $b > $uintmax; + $b = $b -> numify(); + return $x -> bnan() if $b <= 0 || $y -> {sign} eq '-'; $x -> {value} = $LIB -> _lsft($x -> {value}, $y -> {value}, $b); @@ -3070,21 +3390,48 @@ sub brsft { # (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]), @_); - # 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('brsft'); - return $x -> bnan() if ($x -> {sign} !~ /^[+-]$/ || $y -> {sign} !~ /^[+-]$/); + return $x -> bnan(@r) if $x -> {sign} !~ /^[+-]$/ || + $y -> {sign} !~ /^[+-]$/; return $x -> round(@r) if $y -> is_zero(); return $x -> bzero(@r) if $x -> is_zero(); # 0 => 0 $b = 2 if !defined $b; - return $x -> bnan() if $b <= 0 || $y -> {sign} eq '-'; + return $x -> bnan(@r) if $b <= 0 || $y -> {sign} eq '-'; + $b = $class -> new($b) unless defined(blessed($b)); + + # Shifting right by a positive amount might lead to a non-integer result, so + # include this case in the test. + + return $upgrade -> brsft($x, $y, $b, @r) + if defined($upgrade) && (!$x -> isa($class) || + !$y -> isa($class) || + !$b -> isa($class) || + $y -> is_pos()); + + # 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; + + $b = $b -> numify(); # this only works for negative numbers when shifting in base 2 if (($x -> {sign} eq '-') && ($b == 2)) { @@ -3095,7 +3442,7 @@ sub brsft { # shift... # if $y != 1, we must simulate it by doing: # convert to bin, flip all bits, shift, and be done - $x -> binc(); # -3 => -2 + $x = $x -> binc(); # -3 => -2 my $bin = $x -> as_bin(); $bin =~ s/^-0b//; # strip '-0b' prefix $bin =~ tr/10/01/; # flip bits @@ -3111,13 +3458,13 @@ sub brsft { $bin =~ tr/10/01/; # flip bits back } my $res = $class -> new('0b' . $bin); # add prefix and convert back - $res -> binc(); # remember to increment + $res = $res -> binc(); # remember to increment $x -> {value} = $res -> {value}; # take over value return $x -> round(@r); # we are done now, magic, isn't? } # x < 0, n == 2, y == 1 - $x -> bdec(); # n == 2, but $y == 1: this fixes it + $x = $x -> bdec(); # n == 2, but $y == 1: this fixes it } $x -> {value} = $LIB -> _rsft($x -> {value}, $y -> {value}, $b); @@ -3132,18 +3479,18 @@ sub band { #(BINT or num_str, BINT or num_str) return BINT # compute x & y - # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) : objectify(2, @_); return $x if $x->modify('band'); + return $upgrade -> band($x, $y, @r) + if defined($upgrade) && (!$x -> isa($class) || + !$y -> isa($class)); + $r[3] = $y; # no push! - return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/); + return $x->bnan(@r) if $x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/; if ($x->{sign} eq '+' && $y->{sign} eq '+') { $x->{value} = $LIB->_and($x->{value}, $y->{value}); @@ -3158,15 +3505,15 @@ sub bior { #(BINT or num_str, BINT or num_str) return BINT # compute x | y - # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) : objectify(2, @_); return $x if $x->modify('bior'); + return $upgrade -> bior($x, $y, @r) + if defined($upgrade) && (!$x -> isa($class) || + !$y -> isa($class)); + $r[3] = $y; # no push! return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/); @@ -3184,18 +3531,18 @@ sub bxor { #(BINT or num_str, BINT or num_str) return BINT # compute x ^ y - # set up parameters - my ($class, $x, $y, @r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, @r) = objectify(2, @_); - } + my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) : objectify(2, @_); return $x if $x->modify('bxor'); + return $upgrade -> bxor($x, $y, @r) + if defined($upgrade) && (!$x -> isa($class) || + !$y -> isa($class)); + $r[3] = $y; # no push! - return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/); + return $x->bnan(@r) if $x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/; if ($x->{sign} eq '+' && $y->{sign} eq '+') { $x->{value} = $LIB->_xor($x->{value}, $y->{value}); @@ -3209,11 +3556,14 @@ sub bxor { sub bnot { # (num_str or BINT) return BINT # represent ~x as twos-complement number - # we don't need $class, so undef instead of ref($_[0]) make it slightly faster - my ($class, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); return $x if $x->modify('bnot'); - $x->binc()->bneg(); # binc already does round + + return $upgrade -> bnot($x, @r) + if defined($upgrade) && !$x -> isa($class); + + $x -> binc() -> bneg(@r); } ############################################################################### @@ -3224,22 +3574,39 @@ sub round { # Round $self according to given parameters, or given second argument's # parameters or global defaults - # for speed reasons, _find_round_parameters is embedded here: + my ($class, $self, @args) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + # $x->round(undef, undef) signals no rounding + + if (@args >= 2 && @args <= 3 && !defined($args[0]) && !defined($args[1])) { + $self->{_a} = undef; + $self->{_p} = undef; + return $self; + } + + my ($a, $p, $r) = splice @args, 0, 3; - my ($self, $a, $p, $r, @args) = @_; # $a accuracy, if given by caller # $p precision, if given by caller # $r round_mode, if given by caller # @args all 'other' arguments (0 for unary, 1 for binary ops) - my $class = ref($self); # find out class of argument(s) - no strict 'refs'; + if (defined $a) { + croak "accuracy must be a number, not '$a'" + unless $a =~/^[+-]?(?:\d+(?:\.\d*)?|\.\d+)(?:[Ee][+-]?\d+)?\z/; + } + + if (defined $p) { + croak "precision must be a number, not '$p'" + unless $p =~/^[+-]?(?:\d+(?:\.\d*)?|\.\d+)(?:[Ee][+-]?\d+)?\z/; + } # now pick $a or $p, but only if we have got "arguments" if (!defined $a) { foreach ($self, @args) { # take the defined one, or if both defined, the one that is smaller - $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a); + $a = $_->{_a} + if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a); } } if (!defined $p) { @@ -3247,10 +3614,13 @@ sub round { foreach ($self, @args) { # take the defined one, or if both defined, the one that is bigger # -2 > -3, and 3 > 2 - $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p); + $p = $_->{_p} + if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p); } } + no strict 'refs'; + # if still none defined, use globals unless (defined $a || defined $p) { $a = ${"$class\::accuracy"}; @@ -3273,9 +3643,11 @@ sub round { # now round, by calling either bround or bfround: if (defined $a) { - $self->bround(int($a), $r) if !defined $self->{_a} || $self->{_a} >= $a; + $self = $self->bround(int($a), $r) + if !defined $self->{_a} || $self->{_a} >= $a; } else { # both can't be undefined due to early out - $self->bfround(int($p), $r) if !defined $self->{_p} || $self->{_p} <= $p; + $self = $self->bfround(int($p), $r) + if !defined $self->{_p} || $self->{_p} <= $p; } # bround() or bfround() already called bnorm() if nec. @@ -3289,9 +3661,9 @@ sub bround { # and overwrite the rest with 0's, return normalized number # do not return $x->bnorm(), but $x - my $x = shift; - $x = __PACKAGE__->new($x) unless ref $x; - my ($scale, $mode) = $x->_scale_a(@_); + my ($class, $x, @a) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + my ($scale, $mode) = $x->_scale_a(@a); return $x if !defined $scale || $x->modify('bround'); # no-op if ($x->is_zero() || $scale == 0) { @@ -3303,8 +3675,8 @@ sub bround { # we have fewer digits than we want to scale to my $len = $x->length(); # convert $scale to a scalar in case it is an object (put's a limit on the - # number length, but this would already limited by memory constraints), makes - # it faster + # number length, but this would already limited by memory constraints), + # makes it faster $scale = $scale->numify() if ref ($scale); # scale < 0, but > -len (not >=!) @@ -3352,9 +3724,10 @@ sub bround { if (($pad > 0) && ($pad <= $len)) { substr($xs, -$pad, $pad) = '0' x $pad; # replace with '00...' + $xs =~ s/^0+(\d)/$1/; # "00000" -> "0" $put_back = 1; # need to put back } elsif ($pad > $len) { - $x->bzero(); # round to '0' + $x = $x->bzero(); # round to '0' } if ($round_up) { # what gave test above? @@ -3373,7 +3746,6 @@ sub bround { last if $c != 0; # no overflow => early out } $xs = '1'.$xs if $c == 0; - } $x->{value} = $LIB->_new($xs) if $put_back == 1; # put back, if needed @@ -3388,16 +3760,15 @@ sub bround { sub bfround { # precision: round to the $Nth digit left (+$n) or right (-$n) from the '.' # $n == 0 || $n == 1 => round to integer - my $x = shift; - my $class = ref($x) || $x; - $x = $class->new($x) unless ref $x; - my ($scale, $mode) = $x->_scale_p(@_); + my ($class, $x, @p) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + my ($scale, $mode) = $x->_scale_p(@p); return $x if !defined $scale || $x->modify('bfround'); # no-op # no-op for Math::BigInt objects if $n <= 0 - $x->bround($x->length()-$scale, $mode) if $scale > 0; + $x = $x->bround($x->length()-$scale, $mode) if $scale > 0; delete $x->{_a}; # delete to save memory $x->{_p} = $scale; # store new _p @@ -3414,21 +3785,30 @@ sub fround { sub bfloor { # round towards minus infinity; no-op since it's already integer - my ($class, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + return $upgrade -> bfloor($x) + if defined($upgrade) && !$x -> isa($class); $x->round(@r); } sub bceil { # round towards plus infinity; no-op since it's already int - my ($class, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + return $upgrade -> bceil($x) + if defined($upgrade) && !$x -> isa($class); $x->round(@r); } sub bint { # round towards zero; no-op since it's already integer - my ($class, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + return $upgrade -> bint($x) + if defined($upgrade) && !$x -> isa($class); $x->round(@r); } @@ -3442,8 +3822,30 @@ sub bgcd { # does not modify arguments, but returns new object # GCD -- Euclid's algorithm, variant C (Knuth Vol 3, pg 341 ff) + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) + { + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; + unshift @_, __PACKAGE__; + } + my ($class, @args) = objectify(0, @_); + # Upgrade? + + if (defined $upgrade) { + my $do_upgrade = 0; + for my $arg (@args) { + unless ($arg -> isa($class)) { + $do_upgrade = 1; + last; + } + } + return $upgrade -> bgcd(@args) if $do_upgrade; + } + my $x = shift @args; $x = ref($x) && $x -> isa($class) ? $x -> copy() : $class -> new($x); @@ -3465,8 +3867,30 @@ sub blcm { # does not modify arguments, but returns new object # Least Common Multiple + # Class::method(...) -> Class->method(...) + unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || + $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) + { + #carp "Using ", (caller(0))[3], "() as a function is deprecated;", + # " use is as a method instead"; + unshift @_, __PACKAGE__; + } + my ($class, @args) = objectify(0, @_); + # Upgrade? + + if (defined $upgrade) { + my $do_upgrade = 0; + for my $arg (@args) { + unless ($arg -> isa($class)) { + $do_upgrade = 1; + last; + } + } + return $upgrade -> blcm(@args) if $do_upgrade; + } + my $x = shift @args; $x = ref($x) && $x -> isa($class) ? $x -> copy() : $class -> new($x); return $class->bnan() if $x->{sign} !~ /^[+-]$/; # x NaN? @@ -3487,14 +3911,18 @@ sub blcm { sub sign { # return the sign of the number: +/-/-inf/+inf/NaN - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; $x->{sign}; } sub digit { # return the nth decimal digit, negative values count backward, 0 is right - my ($class, $x, $n) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + my (undef, $x, $n, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; $n = $n->numify() if ref($n); $LIB->_digit($x->{value}, $n || 0); @@ -3502,7 +3930,9 @@ sub digit { sub bdigitsum { # like digitsum(), but assigns the result to the invocand - my $x = shift; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; return $x if $x -> is_nan(); return $x -> bnan() if $x -> is_inf(); @@ -3514,19 +3944,22 @@ sub bdigitsum { sub digitsum { # compute sum of decimal digits and return it - my $x = shift; - my $class = ref $x; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 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; + $y -> round(@r); } sub length { - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; my $e = $LIB->_len($x->{value}); wantarray ? ($e, 0) : $e; @@ -3534,26 +3967,40 @@ sub length { sub exponent { # return a copy of the exponent (here always 0, NaN or 1 for $m == 0) - my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Upgrade? + + return $upgrade -> exponent($x, @r) + if defined($upgrade) && !$x -> isa($class); if ($x->{sign} !~ /^[+-]$/) { my $s = $x->{sign}; $s =~ s/^[+-]//; # NaN, -inf, +inf => NaN or inf - return $class->new($s); + return $class->new($s, @r); } - return $class->bzero() if $x->is_zero(); + return $class->bzero(@r) if $x->is_zero(); # 12300 => 2 trailing zeros => exponent is 2 - $class->new($LIB->_zeros($x->{value})); + $class->new($LIB->_zeros($x->{value}), @r); } sub mantissa { # return the mantissa (compatible to Math::BigFloat, e.g. reduced) - my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Upgrade? + + return $upgrade -> mantissa($x, @r) + if defined($upgrade) && !$x -> isa($class); if ($x->{sign} !~ /^[+-]$/) { # for NaN, +inf, -inf: keep the sign - return $class->new($x->{sign}); + return $class->new($x->{sign}, @r); } my $m = $x->copy(); delete $m->{_p}; @@ -3561,92 +4008,100 @@ sub mantissa { # that's a bit inefficient: my $zeros = $LIB->_zeros($m->{value}); - $m->brsft($zeros, 10) if $zeros != 0; - $m; + $m = $m->brsft($zeros, 10) if $zeros != 0; + $m -> round(@r); } sub parts { # return a copy of both the exponent and the mantissa - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Upgrade? - ($x->mantissa(), $x->exponent()); + return $upgrade -> parts($x, @r) + if defined($upgrade) && !$x -> isa($class); + + ($x->mantissa(@r), $x->exponent(@r)); } +# Parts used for scientific notation with significand/mantissa and exponent as +# integers. E.g., "12345.6789" is returned as "123456789" (mantissa) and "-4" +# (exponent). + sub sparts { - my $self = shift; - my $class = ref $self; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - croak("sparts() is an instance method, not a class method") - unless $class; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; # Not-a-number. - if ($self -> is_nan()) { - my $mant = $self -> copy(); # mantissa + if ($x -> is_nan()) { + my $mant = $class -> bnan(@r); # mantissa return $mant unless wantarray; # scalar context - my $expo = $class -> bnan(); # exponent + my $expo = $class -> bnan(@r); # exponent return ($mant, $expo); # list context } # Infinity. - if ($self -> is_inf()) { - my $mant = $self -> copy(); # mantissa - return $mant unless wantarray; # scalar context - my $expo = $class -> binf('+'); # exponent - return ($mant, $expo); # list context + if ($x -> is_inf()) { + my $mant = $class -> binf($x->{sign}, @r); # mantissa + return $mant unless wantarray; # scalar context + my $expo = $class -> binf('+', @r); # exponent + return ($mant, $expo); # list context } + # Upgrade? + + return $upgrade -> sparts($x, @r) + if defined($upgrade) && !$x -> isa($class); + # Finite number. - my $mant = $self -> copy(); + my $mant = $x -> copy(); my $nzeros = $LIB -> _zeros($mant -> {value}); - $mant -> brsft($nzeros, 10) if $nzeros != 0; + $mant -> {value} + = $LIB -> _rsft($mant -> {value}, $LIB -> _new($nzeros), 10) + if $nzeros != 0; return $mant unless wantarray; - my $expo = $class -> new($nzeros); + my $expo = $class -> new($nzeros, @r); return ($mant, $expo); } +# Parts used for normalized notation with significand/mantissa as either 0 or a +# number in the semi-open interval [1,10). E.g., "12345.6789" is returned as +# "1.23456789" and "4". + sub nparts { - my $self = shift; - my $class = ref $self; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - croak("nparts() is an instance method, not a class method") - unless $class; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - # Not-a-number. + # Not-a-Number and Infinity. - if ($self -> is_nan()) { - my $mant = $self -> copy(); # mantissa - return $mant unless wantarray; # scalar context - my $expo = $class -> bnan(); # exponent - return ($mant, $expo); # list context - } + return $x -> sparts(@r) if $x -> is_nan() || $x -> is_inf(); - # Infinity. + # Upgrade? - if ($self -> is_inf()) { - my $mant = $self -> copy(); # mantissa - return $mant unless wantarray; # scalar context - my $expo = $class -> binf('+'); # exponent - return ($mant, $expo); # list context - } + return $upgrade -> nparts($x, @r) + if defined($upgrade) && !$x -> isa($class); # Finite number. - my ($mant, $expo) = $self -> sparts(); - + my ($mant, $expo) = $x -> sparts(@r); if ($mant -> bcmp(0)) { my ($ndigtot, $ndigfrac) = $mant -> length(); my $expo10adj = $ndigtot - $ndigfrac - 1; - if ($expo10adj != 0) { - return $upgrade -> new($self) -> nparts() if $upgrade; - $mant -> bnan(); + if ($expo10adj > 0) { # if mantissa is not an integer + return $upgrade -> nparts($x, @r) if defined $upgrade; + $mant = $mant -> bnan(@r); return $mant unless wantarray; - $expo -> badd($expo10adj); + $expo = $expo -> badd($expo10adj, @r); return ($mant, $expo); } } @@ -3655,70 +4110,174 @@ sub nparts { return ($mant, $expo); } +# Parts used for engineering notation with significand/mantissa as either 0 or a +# number in the semi-open interval [1,1000) and the exponent is a multiple of 3. +# E.g., "12345.6789" is returned as "12.3456789" and "3". + sub eparts { - my $self = shift; - my $class = ref $self; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - croak("eparts() is an instance method, not a class method") - unless $class; + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; # Not-a-number and Infinity. - return $self -> sparts() if $self -> is_nan() || $self -> is_inf(); + return $x -> sparts(@r) if $x -> is_nan() || $x -> is_inf(); + + # Upgrade? + + return $upgrade -> eparts($x, @r) + if defined($upgrade) && !$x -> isa($class); # Finite number. - my ($mant, $expo) = $self -> sparts(); + my ($mant, $expo) = $x -> sparts(@r); if ($mant -> bcmp(0)) { my $ndigmant = $mant -> length(); - $expo -> badd($ndigmant); + $expo = $expo -> badd($ndigmant, @r); # $c is the number of digits that will be in the integer part of the # final mantissa. my $c = $expo -> copy() -> bdec() -> bmod(3) -> binc(); - $expo -> bsub($c); + $expo = $expo -> bsub($c); if ($ndigmant > $c) { - return $upgrade -> new($self) -> eparts() if $upgrade; - $mant -> bnan(); + return $upgrade -> eparts($x, @r) if defined $upgrade; + $mant = $mant -> bnan(@r); return $mant unless wantarray; return ($mant, $expo); } - $mant -> blsft($c - $ndigmant, 10); + $mant = $mant -> blsft($c - $ndigmant, 10, @r); } return $mant unless wantarray; return ($mant, $expo); } +# Parts used for decimal notation, e.g., "12345.6789" is returned as "12345" +# (integer part) and "0.6789" (fraction part). + sub dparts { - my $self = shift; - my $class = ref $self; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - croak("dparts() is an instance method, not a class method") - unless $class; + # Not-a-number. + + if ($x -> is_nan()) { + my $int = $class -> bnan(@r); + return $int unless wantarray; + my $frc = $class -> bzero(@r); # or NaN? + return ($int, $frc); + } + + # Infinity. + + if ($x -> is_inf()) { + my $int = $class -> binf($x->{sign}, @r); + return $int unless wantarray; + my $frc = $class -> bzero(@r); + return ($int, $frc); + } + + # Upgrade? - my $int = $self -> copy(); + return $upgrade -> dparts($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number. + + my $int = $x -> copy() -> round(@r); return $int unless wantarray; - my $frc = $class -> bzero(); + my $frc = $class -> bzero(@r); return ($int, $frc); } +# Fractional parts with the numerator and denominator as integers. E.g., +# "123.4375" is returned as "1975" and "16". + +sub fparts { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # NaN => NaN/NaN + + if ($x -> is_nan()) { + return $class -> bnan(@r) unless wantarray; + return $class -> bnan(@r), $class -> bnan(@r); + } + + # ±Inf => ±Inf/1 + + if ($x -> is_inf()) { + my $numer = $class -> binf($x->{sign}, @r); + return $numer unless wantarray; + my $denom = $class -> bone(@r); + return $numer, $denom; + } + + # Upgrade? + + return $upgrade -> fparts($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # N => N/1 + + my $numer = $x -> copy() -> round(@r); + return $numer unless wantarray; + my $denom = $class -> bone(@r); + return $numer, $denom; +} + +sub numerator { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + return $upgrade -> numerator($x, @r) + if defined($upgrade) && !$x -> isa($class); + + return $x -> copy() -> round(@r); +} + +sub denominator { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + return $upgrade -> denominator($x, @r) + if defined($upgrade) && !$x -> isa($class); + + return $x -> is_nan() ? $class -> bnan(@r) : $class -> bone(@r); +} + ############################################################################### # String conversion methods ############################################################################### sub bstr { - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN if ($x->{sign} ne '+' && $x->{sign} ne '-') { return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN return 'inf'; # +inf } + + # Upgrade? + + return $upgrade -> bstr($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number + my $str = $LIB->_str($x->{value}); return $x->{sign} eq '-' ? "-$str" : $str; } @@ -3727,125 +4286,223 @@ sub bstr { # written as "1.2345e+4". sub bsstr { - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN if ($x->{sign} ne '+' && $x->{sign} ne '-') { return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN return 'inf'; # +inf } - my ($m, $e) = $x -> parts(); - my $str = $LIB->_str($m->{value}) . 'e+' . $LIB->_str($e->{value}); - return $x->{sign} eq '-' ? "-$str" : $str; + + # Upgrade? + + return $upgrade -> bsstr($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number + + my $expo = $LIB -> _zeros($x->{value}); + my $mant = $LIB -> _str($x->{value}); + $mant = substr($mant, 0, -$expo) if $expo; # strip trailing zeros + + ($x->{sign} eq '-' ? '-' : '') . $mant . 'e+' . $expo; } -# Normalized notation, e.g., "12345" is written as "12345e+0". +# Normalized notation, e.g., "12345" is written as "1.2345e+4". sub bnstr { - my $x = shift; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN if ($x->{sign} ne '+' && $x->{sign} ne '-') { return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN return 'inf'; # +inf } - return $x -> bstr() if $x -> is_nan() || $x -> is_inf(); + # Upgrade? - my ($mant, $expo) = $x -> parts(); + return $upgrade -> bnstr($x, @r) + if defined($upgrade) && !$x -> isa($class); - # The "fraction posision" is the position (offset) for the decimal point - # relative to the end of the digit string. + # Finite number - my $fracpos = $mant -> length() - 1; - if ($fracpos == 0) { - my $str = $LIB->_str($mant->{value}) . "e+" . $LIB->_str($expo->{value}); - return $x->{sign} eq '-' ? "-$str" : $str; - } + my $expo = $LIB -> _zeros($x->{value}); + my $mant = $LIB -> _str($x->{value}); + $mant = substr($mant, 0, -$expo) if $expo; # strip trailing zeros - $expo += $fracpos; - my $mantstr = $LIB->_str($mant -> {value}); - substr($mantstr, -$fracpos, 0) = '.'; + my $mantlen = CORE::length($mant); + if ($mantlen > 1) { + $expo += $mantlen - 1; # adjust exponent + substr $mant, 1, 0, "."; # insert decimal point + } - my $str = $mantstr . 'e+' . $LIB->_str($expo -> {value}); - return $x->{sign} eq '-' ? "-$str" : $str; + ($x->{sign} eq '-' ? '-' : '') . $mant . 'e+' . $expo; } # Engineering notation, e.g., "12345" is written as "12.345e+3". sub bestr { - my $x = shift; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN if ($x->{sign} ne '+' && $x->{sign} ne '-') { return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN return 'inf'; # +inf } - my ($mant, $expo) = $x -> parts(); + # Upgrade? - my $sign = $mant -> sign(); - $mant -> babs(); + return $upgrade -> bestr($x, @r) + if defined($upgrade) && !$x -> isa($class); - my $mantstr = $LIB->_str($mant -> {value}); - my $mantlen = CORE::length($mantstr); + # Finite number - my $dotidx = 1; - $expo += $mantlen - 1; + my $expo = $LIB -> _zeros($x->{value}); # number of trailing zeros + my $mant = $LIB -> _str($x->{value}); # mantissa as a string + $mant = substr($mant, 0, -$expo) if $expo; # strip trailing zeros + my $mantlen = CORE::length($mant); # length of mantissa + $expo += $mantlen; - my $c = $expo -> copy() -> bmod(3); - $expo -= $c; - $dotidx += $c; + my $dotpos = ($expo - 1) % 3 + 1; # offset of decimal point + $expo -= $dotpos; - if ($mantlen < $dotidx) { - $mantstr .= "0" x ($dotidx - $mantlen); - } elsif ($mantlen > $dotidx) { - substr($mantstr, $dotidx, 0) = "."; + if ($dotpos < $mantlen) { + substr $mant, $dotpos, 0, "."; # insert decimal point + } elsif ($dotpos > $mantlen) { + $mant .= "0" x ($dotpos - $mantlen); # append zeros } - my $str = $mantstr . 'e+' . $LIB->_str($expo -> {value}); - return $sign eq "-" ? "-$str" : $str; + ($x->{sign} eq '-' ? '-' : '') . $mant . 'e+' . $expo; } -# Decimal notation, e.g., "12345". +# Decimal notation, e.g., "12345" (no exponent). sub bdstr { - my $x = shift; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN if ($x->{sign} ne '+' && $x->{sign} ne '-') { - return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN - return 'inf'; # +inf + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf } - my $str = $LIB->_str($x->{value}); - return $x->{sign} eq '-' ? "-$str" : $str; + # Upgrade? + + return $upgrade -> bdstr($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number + + ($x->{sign} eq '-' ? '-' : '') . $LIB->_str($x->{value}); +} + +# Fraction notation, e.g., "123.4375" is written as "1975/16", but "123" is +# written as "123", not "123/1". + +sub bfstr { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN + + if ($x->{sign} ne '+' && $x->{sign} ne '-') { + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf + } + + # Upgrade? + + return $upgrade -> bfstr($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number + + ($x->{sign} eq '-' ? '-' : '') . $LIB->_str($x->{value}); } sub to_hex { - # return as hex string, with prefixed 0x - my $x = shift; - $x = __PACKAGE__->new($x) if !ref($x); + # return as hex string with no prefix - return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN + + if ($x->{sign} ne '+' && $x->{sign} ne '-') { + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf + } + + # Upgrade? + + return $upgrade -> to_hex($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number my $hex = $LIB->_to_hex($x->{value}); return $x->{sign} eq '-' ? "-$hex" : $hex; } sub to_oct { - # return as octal string, with prefixed 0 - my $x = shift; - $x = __PACKAGE__->new($x) if !ref($x); + # return as octal string with no prefix - return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN + + if ($x->{sign} ne '+' && $x->{sign} ne '-') { + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf + } + + # Upgrade? + + return $upgrade -> to_oct($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number my $oct = $LIB->_to_oct($x->{value}); return $x->{sign} eq '-' ? "-$oct" : $oct; } sub to_bin { - # return as binary string, with prefixed 0b - my $x = shift; - $x = __PACKAGE__->new($x) if !ref($x); + # return as binary string with no prefix - return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN + + if ($x->{sign} ne '+' && $x->{sign} ne '-') { + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf + } + + # Upgrade? + + return $upgrade -> to_bin($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number my $bin = $LIB->_to_bin($x->{value}); return $x->{sign} eq '-' ? "-$bin" : $bin; @@ -3853,12 +4510,17 @@ sub to_bin { sub to_bytes { # return a byte string - my $x = shift; - $x = __PACKAGE__->new($x) if !ref($x); + + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; croak("to_bytes() requires a finite, non-negative integer") if $x -> is_neg() || ! $x -> is_int(); + return $upgrade -> to_bytes($x, @r) + if defined($upgrade) && !$x -> isa($class); + croak("to_bytes() requires a newer version of the $LIB library.") unless $LIB->can('_to_bytes'); @@ -3867,22 +4529,23 @@ sub to_bytes { sub to_base { # return a base anything string - my $x = shift; - $x = __PACKAGE__->new($x) if !ref($x); + + # $cs is the collation sequence + my ($class, $x, $base, $cs, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) : objectify(2, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; croak("the value to convert must be a finite, non-negative integer") if $x -> is_neg() || !$x -> is_int(); - my $base = shift; - $base = __PACKAGE__->new($base) unless ref($base); - croak("the base must be a finite integer >= 2") if $base < 2 || ! $base -> is_int(); # If no collating sequence is given, pass some of the conversions to # methods optimized for those cases. - if (! @_) { + unless (defined $cs) { return $x -> to_bin() if $base == 2; return $x -> to_oct() if $base == 8; return uc $x -> to_hex() if $base == 16; @@ -3892,38 +4555,93 @@ sub to_base { croak("to_base() requires a newer version of the $LIB library.") unless $LIB->can('_to_base'); - return $LIB->_to_base($x->{value}, $base -> {value}, @_ ? shift() : ()); + return $upgrade -> to_base($x, $base, $cs, @r) + if defined($upgrade) && (!$x -> isa($class) || !$base -> isa($class)); + + return $LIB->_to_base($x->{value}, $base -> {value}, + defined($cs) ? $cs : ()); +} + +sub to_base_num { + # return a base anything array ref, e.g., + # Math::BigInt -> new(255) -> to_base_num(10) returns [2, 5, 5]; + + # $cs is the collation sequence + my ($class, $x, $base, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) + ? (ref($_[0]), @_) : objectify(2, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + croak("the value to convert must be a finite non-negative integer") + if $x -> is_neg() || !$x -> is_int(); + + croak("the base must be a finite integer >= 2") + if $base < 2 || ! $base -> is_int(); + + croak("to_base() requires a newer version of the $LIB library.") + unless $LIB->can('_to_base'); + + return $upgrade -> to_base_num($x, $base, @r) + if defined($upgrade) && (!$x -> isa($class) || !$base -> isa($class)); + + # Get a reference to an array of library thingies, and replace each element + # with a Math::BigInt object using that thingy. + + my $vals = $LIB -> _to_base_num($x->{value}, $base -> {value}); + + for my $i (0 .. $#$vals) { + my $x = $class -> bzero(); + $x -> {value} = $vals -> [$i]; + $vals -> [$i] = $x; + } + + return $vals; } sub as_hex { # return as hex string, with prefixed 0x - my $x = shift; - $x = __PACKAGE__->new($x) if !ref($x); + + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc + return $upgrade -> as_hex($x, @r) + if defined($upgrade) && !$x -> isa($class); + my $hex = $LIB->_as_hex($x->{value}); return $x->{sign} eq '-' ? "-$hex" : $hex; } sub as_oct { # return as octal string, with prefixed 0 - my $x = shift; - $x = __PACKAGE__->new($x) if !ref($x); + + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc + return $upgrade -> as_oct($x, @r) + if defined($upgrade) && !$x -> isa($class); + my $oct = $LIB->_as_oct($x->{value}); return $x->{sign} eq '-' ? "-$oct" : $oct; } sub as_bin { # return as binary string, with prefixed 0b - my $x = shift; - $x = __PACKAGE__->new($x) if !ref($x); + + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc + return $upgrade -> as_bin($x, @r) + if defined($upgrade) && !$x -> isa($class); + my $bin = $LIB->_as_bin($x->{value}); return $x->{sign} eq '-' ? "-$bin" : $bin; } @@ -3936,21 +4654,25 @@ sub as_bin { sub numify { # Make a Perl scalar number from a Math::BigInt object. - my $x = shift; - $x = __PACKAGE__->new($x) unless ref $x; + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; if ($x -> is_nan()) { require Math::Complex; - my $inf = Math::Complex::Inf(); + my $inf = $Math::Complex::Inf; return $inf - $inf; } if ($x -> is_inf()) { require Math::Complex; - my $inf = Math::Complex::Inf(); + my $inf = $Math::Complex::Inf; return $x -> is_negative() ? -$inf : $inf; } + return $upgrade -> numify($x, @r) + if defined($upgrade) && !$x -> isa($class); + my $num = 0 + $LIB->_num($x->{value}); return $x->{sign} eq '-' ? -$num : $num; } @@ -4015,9 +4737,13 @@ sub objectify { no strict 'refs'; - # What we upgrade to, if anything. + # What we upgrade to, if anything. Note that we need the whole upgrade + # chain, since there might be multiple levels of upgrading. E.g., class A + # upgrades to class B, which upgrades to class C. Delay getting the chain + # until we actually need it. - my $up = ${"$a[0]::upgrade"}; + my @upg = (); + my $have_upgrade_chain = 0; # Disable downgrading, because Math::BigFloat -> foo('1.0', '2.0') needs # floats. @@ -4028,7 +4754,7 @@ sub objectify { ${"$a[0]::downgrade"} = undef; } - for my $i (1 .. $count) { + ARG: for my $i (1 .. $count) { my $ref = ref $a[$i]; @@ -4043,10 +4769,23 @@ sub objectify { next if $ref -> isa($a[0]); - # Upgrading is OK, so skip further tests if the argument is upgraded. + # Upgrading is OK, so skip further tests if the argument is upgraded, + # but first get the whole upgrade chain if we haven't got it yet. + + unless ($have_upgrade_chain) { + my $cls = $class; + my $upg = $cls -> upgrade(); + while (defined $upg) { + last if $upg eq $cls; + push @upg, $upg; + $cls = $upg; + $upg = $cls -> upgrade(); + } + $have_upgrade_chain = 1; + } - if (defined $up && $ref -> isa($up)) { - next; + for my $upg (@upg) { + next ARG if $ref -> isa($upg); } # See if we can call one of the as_xxx() methods. We don't know whether @@ -4105,233 +4844,190 @@ sub import { my $class = shift; $IMPORT++; # remember we did import() my @a; # unrecognized arguments - my $warn_or_die = 0; # 0 - no warn, 1 - warn, 2 - die - for (my $i = 0; $i <= $#_ ; $i++) { - if ($_[$i] eq ':constant') { - # this causes overlord er load to step in + + while (@_) { + my $param = shift; + + # Enable overloading of constants. + + if ($param eq ':constant') { overload::constant - integer => sub { $class->new(shift) }, - binary => sub { $class->new(shift) }; - } elsif ($_[$i] eq 'upgrade') { - # this causes upgrading - $upgrade = $_[$i+1]; # or undef to disable - $i++; - } elsif ($_[$i] =~ /^(lib|try|only)\z/) { - # this causes a different low lib to take care... - $LIB = $_[$i+1] || ''; - # 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++; - } else { - push @a, $_[$i]; + + integer => sub { + $class -> new(shift); + }, + + float => sub { + $class -> new(shift); + }, + + binary => sub { + # E.g., a literal 0377 shall result in an object whose value + # is decimal 255, but new("0377") returns decimal 377. + return $class -> from_oct($_[0]) if $_[0] =~ /^0_*[0-7]/; + $class -> new(shift); + }; + next; } - } - # any non :constant stuff is handled by our parent, Exporter - if (@a > 0) { - $class->SUPER::import(@a); # need it for subclasses - $class->export_to_level(1, $class, @a); # need it for MBF - } - - # try to load core math lib - my @c = split /\s*,\s*/, $LIB; - foreach (@c) { - 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 - foreach my $l (@c) { - # fallback libraries are "marked" as \'string', extract string if nec. - my $lib = $l; - $lib = $$l if ref($l); - - next unless defined($lib) && CORE::length($lib); - $lib = 'Math::BigInt::'.$lib if $lib !~ /^Math::BigInt/i; - $lib =~ s/\.pm$//; - 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 '') { - $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 + + # Upgrading. + + if ($param eq 'upgrade') { + $class -> upgrade(shift); + next; } - } - if ($LIB eq '') { - if ($warn_or_die == 2) { - croak("Couldn't load specified math lib(s)" . - " and fallback disallowed"); - } else { - croak("Couldn't load any math lib(s), not even fallback to Calc.pm"); + + # Downgrading. + + if ($param eq 'downgrade') { + $class -> downgrade(shift); + next; } - } - # notify callbacks - foreach my $class (keys %CALLBACKS) { - &{$CALLBACKS{$class}}($LIB); - } + # Accuracy. - # import done -} + if ($param eq 'accuracy') { + $class -> accuracy(shift); + next; + } -sub _register_callback { - my ($class, $callback) = @_; + # Precision. - if (ref($callback) ne 'CODE') { - croak("$callback is not a coderef"); - } - $CALLBACKS{$class} = $callback; -} + if ($param eq 'precision') { + $class -> precision(shift); + next; + } -sub _split_dec_string { - my $str = shift; + # Rounding mode. - if ($str =~ s/ - ^ + if ($param eq 'round_mode') { + $class -> round_mode(shift); + next; + } - # leading whitespace - ( \s* ) + # Backend library. - # optional sign - ( [+-]? ) + if ($param =~ /^(lib|try|only)\z/) { + # try => 0 (no warn if unavailable module) + # lib => 1 (warn on fallback) + # only => 2 (die on fallback) - # significand - ( - \d+ (?: _ \d+ )* - (?: - \. - (?: \d+ (?: _ \d+ )* )? - )? - | - \. - \d+ (?: _ \d+ )* - ) - - # optional exponent - (?: - [Ee] - ( [+-]? ) - ( \d+ (?: _ \d+ )* ) - )? - - # trailing stuff - ( \D .*? )? + # Get the list of user-specified libraries. - \z - //x) { - my $leading = $1; - my $significand_sgn = $2 || '+'; - my $significand_abs = $3; - my $exponent_sgn = $4 || '+'; - my $exponent_abs = $5 || '0'; - my $trailing = $6; - - # Remove underscores and leading zeros. - - $significand_abs =~ tr/_//d; - $exponent_abs =~ tr/_//d; - - $significand_abs =~ s/^0+(.)/$1/; - $exponent_abs =~ s/^0+(.)/$1/; - - # If the significand contains a dot, remove it and adjust the exponent - # accordingly. E.g., "1234.56789e+3" -> "123456789e-2" - - my $idx = index $significand_abs, '.'; - if ($idx > -1) { - $significand_abs =~ s/0+\z//; - substr($significand_abs, $idx, 1) = ''; - my $exponent = $exponent_sgn . $exponent_abs; - $exponent .= $idx - CORE::length($significand_abs); - $exponent_abs = abs $exponent; - $exponent_sgn = $exponent < 0 ? '-' : '+'; - } + croak "Library argument for import parameter '$param' is missing" + unless @_; + my $libs = shift; + croak "Library argument for import parameter '$param' is undefined" + unless defined($libs); - return($leading, - $significand_sgn, $significand_abs, - $exponent_sgn, $exponent_abs, - $trailing); - } + # Check and clean up the list of user-specified libraries. - return undef; -} + my @libs; + for my $lib (split /,/, $libs) { + $lib =~ s/^\s+//; + $lib =~ s/\s+$//; -sub _split { - # input: num_str; output: undef for invalid or - # (\$mantissa_sign, \$mantissa_value, \$mantissa_fraction, - # \$exp_sign, \$exp_value) - # Internal, take apart a string and return the pieces. - # Strip leading/trailing whitespace, leading zeros, underscore and reject - # invalid input. - my $x = shift; + if ($lib =~ /[^a-zA-Z0-9_:]/) { + carp "Library name '$lib' contains invalid characters"; + next; + } + + if (! CORE::length $lib) { + carp "Library name is empty"; + next; + } - # strip white space at front, also extraneous leading zeros - $x =~ s/^\s*([-]?)0*([0-9])/$1$2/g; # will not strip ' .2' - $x =~ s/^\s+//; # but this will - $x =~ s/\s+$//g; # strip white space at end + $lib = "Math::BigInt::$lib" if $lib !~ /^Math::BigInt::/i; - # shortcut, if nothing to split, return early - if ($x =~ /^[+-]?[0-9]+\z/) { - $x =~ s/^([+-])0*([0-9])/$2/; - my $sign = $1 || '+'; - return (\$sign, \$x, \'', \'', \0); - } + # If a library has already been loaded, that is OK only if the + # requested library is identical to the loaded one. - # invalid starting char? - return if $x !~ /^[+-]?(\.?[0-9]|0b[0-1]|0x[0-9a-fA-F])/; + if (defined($LIB)) { + if ($lib ne $LIB) { + #carp "Library '$LIB' has already been loaded, so", + # " ignoring requested library '$lib'"; + } + next; + } - return Math::BigInt->from_hex($x) if $x =~ /^[+-]?0x/; # hex string - return Math::BigInt->from_bin($x) if $x =~ /^[+-]?0b/; # binary string + push @libs, $lib; + } - # strip underscores between digits - $x =~ s/([0-9])_([0-9])/$1$2/g; - $x =~ s/([0-9])_([0-9])/$1$2/g; # do twice for 1_2_3 + next if defined $LIB; - # some possible inputs: - # 2.1234 # 0.12 # 1 # 1E1 # 2.134E1 # 434E-10 # 1.02009E-2 - # .2 # 1_2_3.4_5_6 # 1.4E1_2_3 # 1e3 # +.2 # 0e999 + croak "Library list contains no valid libraries" unless @libs; - my ($m, $e, $last) = split /[Ee]/, $x; - return if defined $last; # last defined => 1e2E3 or others - $e = '0' if !defined $e || $e eq ""; + # Try to load the specified libraries, if any. - # sign, value for exponent, mantint, mantfrac - my ($es, $ev, $mis, $miv, $mfv); - # valid exponent? - if ($e =~ /^([+-]?)0*([0-9]+)$/) # strip leading zeros - { - $es = $1; - $ev = $2; - # valid mantissa? - return if $m eq '.' || $m eq ''; - my ($mi, $mf, $lastf) = split /\./, $m; - return if defined $lastf; # lastf defined => 1.2.3 or others - $mi = '0' if !defined $mi; - $mi .= '0' if $mi =~ /^[\-\+]?$/; - $mf = '0' if !defined $mf || $mf eq ''; - if ($mi =~ /^([+-]?)0*([0-9]+)$/) # strip leading zeros - { - $mis = $1 || '+'; - $miv = $2; - return unless ($mf =~ /^([0-9]*?)0*$/); # strip trailing zeros - $mfv = $1; - # handle the 0e999 case here - $ev = 0 if $miv eq '0' && $mfv eq ''; - return (\$mis, \$miv, \$mfv, \$es, \$ev); + for (my $i = 0 ; $i <= $#libs ; $i++) { + my $lib = $libs[$i]; + eval "require $lib"; + unless ($@) { + $LIB = $lib; + last; + } + } + + next if defined $LIB; + + # No library has been loaded, and none of the requested libraries + # could be loaded, and fallback and the user doesn't allow fallback. + + if ($param eq 'only') { + croak "Couldn't load the specified math lib(s) ", + join(", ", map "'$_'", @libs), + ", and fallback to '$DEFAULT_LIB' is not allowed"; + } + + # No library has been loaded, and none of the requested libraries + # could be loaded, but the user accepts the use of a fallback + # library, so try to load it. + + eval "require $DEFAULT_LIB"; + if ($@) { + croak "Couldn't load the specified math lib(s) ", + join(", ", map "'$_'", @libs), + ", not even the fallback lib '$DEFAULT_LIB'"; + } + + # The fallback library was successfully loaded, but the user + # might want to know that we are using the fallback. + + if ($param eq 'lib') { + carp "Couldn't load the specified math lib(s) ", + join(", ", map "'$_'", @libs), + ", so using fallback lib '$DEFAULT_LIB'"; + } + + next; } + + # Unrecognized parameter. + + push @a, $param; + } + + # Any non-':constant' stuff is handled by our parent, Exporter + + if (@a) { + $class->SUPER::import(@a); # need it for subclasses + $class->export_to_level(1, $class, @a); # need it for Math::BigFloat + } + + # We might not have loaded any backend library yet, either because the user + # didn't specify any, or because the specified libraries failed to load and + # the user allows the use of a fallback library. + + unless (defined $LIB) { + eval "require $DEFAULT_LIB"; + if ($@) { + croak "No lib specified, and couldn't load the default", + " lib '$DEFAULT_LIB'"; + } + $LIB = $DEFAULT_LIB; } - return; # NaN, not a number + + # import done } sub _trailing_zeros { @@ -4386,7 +5082,8 @@ sub _find_round_parameters { if (!defined $a) { foreach ($self, @args) { # take the defined one, or if both defined, the one that is smaller - $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a); + $a = $_->{_a} + if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a); } } if (!defined $p) { @@ -4394,7 +5091,8 @@ sub _find_round_parameters { foreach ($self, @args) { # take the defined one, or if both defined, the one that is bigger # -2 > -3, and 3 > 2 - $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p); + $p = $_->{_p} + if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p); } } @@ -4422,6 +5120,699 @@ sub _find_round_parameters { ($self, $a, $p, $r); } +# Return true if the input is numeric and false if it is a string. + +sub _is_numeric { + shift; # class name + my $value = shift; + no warnings 'numeric'; + # detect numbers + # string & "" -> "" + # number & "" -> 0 (with warning) + # nan and inf can detect as numbers, so check with * 0 + return unless CORE::length((my $dummy = "") & $value); + return unless 0 + $value eq $value; + return 1 if $value * 0 == 0; + return -1; # Inf/NaN +} + +# Trims the sign of the significand, the (absolute value of the) significand, +# the sign of the exponent, and the (absolute value of the) exponent. The +# returned values have no underscores ("_") or unnecessary leading or trailing +# zeros. + +sub _trim_split_parts { + shift; # class name + + my $sig_sgn = shift() || '+'; + my $sig_str = shift() || '0'; + my $exp_sgn = shift() || '+'; + my $exp_str = shift() || '0'; + + $sig_str =~ tr/_//d; # "1.0_0_0" -> "1.000" + $sig_str =~ s/^0+//; # "01.000" -> "1.000" + $sig_str =~ s/\.0*$// # "1.000" -> "1" + || $sig_str =~ s/(\..*[^0])0+$/$1/; # "1.010" -> "1.01" + $sig_str = '0' unless CORE::length($sig_str); + + return '+', '0', '+', '0' if $sig_str eq '0'; + + $exp_str =~ tr/_//d; # "01_234" -> "01234" + $exp_str =~ s/^0+//; # "01234" -> "1234" + $exp_str = '0' unless CORE::length($exp_str); + $exp_sgn = '+' if $exp_str eq '0'; # "+3e-0" -> "+3e+0" + + return $sig_sgn, $sig_str, $exp_sgn, $exp_str; +} + +# Takes any string representing a valid decimal number and splits it into four +# strings: the sign of the significand, the absolute value of the significand, +# the sign of the exponent, and the absolute value of the exponent. Both the +# significand and the exponent are in base 10. +# +# Perl accepts literals like the following. The value is 100.1. +# +# 1__0__.__0__1__e+0__1__ (prints "Misplaced _ in number") +# 1_0.0_1e+0_1 +# +# Strings representing decimal numbers do not allow underscores, so only the +# following is valid +# +# "10.01e+01" + +sub _dec_str_to_dec_str_parts { + my $class = shift; + my $str = shift; + + if ($str =~ / + ^ + + # optional leading whitespace + \s* + + # optional sign + ( [+-]? ) + + # significand + ( + # integer part and optional fraction part ... + \d+ (?: _+ \d+ )* _* + (?: + \. + (?: _* \d+ (?: _+ \d+ )* _* )? + )? + | + # ... or mandatory fraction part + \. + \d+ (?: _+ \d+ )* _* + ) + + # optional exponent + (?: + [Ee] + ( [+-]? ) + ( \d+ (?: _+ \d+ )* _* ) + )? + + # optional trailing whitespace + \s* + + $ + /x) + { + return $class -> _trim_split_parts($1, $2, $3, $4); + } + + return; +} + +# Takes any string representing a valid hexadecimal number and splits it into +# four strings: the sign of the significand, the absolute value of the +# significand, the sign of the exponent, and the absolute value of the exponent. +# The significand is in base 16, and the exponent is in base 2. +# +# Perl accepts literals like the following. The "x" might be a capital "X". The +# value is 32.0078125. +# +# 0x__1__0__.0__1__p+0__1__ (prints "Misplaced _ in number") +# 0x1_0.0_1p+0_1 +# +# The CORE::hex() function does not accept floating point accepts +# +# "0x_1_0" +# "x_1_0" +# "_1_0" + +sub _hex_str_to_hex_str_parts { + my $class = shift; + my $str = shift; + + if ($str =~ / + ^ + + # optional leading whitespace + \s* + + # optional sign + ( [+-]? ) + + # optional hex prefix + (?: 0? [Xx] _* )? + + # significand using the hex digits 0..9 and a..f + ( + # integer part and optional fraction part ... + [0-9a-fA-F]+ (?: _+ [0-9a-fA-F]+ )* _* + (?: + \. + (?: _* [0-9a-fA-F]+ (?: _+ [0-9a-fA-F]+ )* _* )? + )? + | + # ... or mandatory fraction part + \. + [0-9a-fA-F]+ (?: _+ [0-9a-fA-F]+ )* _* + ) + + # optional exponent (power of 2) using decimal digits + (?: + [Pp] + ( [+-]? ) + ( \d+ (?: _+ \d+ )* _* ) + )? + + # optional trailing whitespace + \s* + + $ + /x) + { + return $class -> _trim_split_parts($1, $2, $3, $4); + } + + return; +} + +# Takes any string representing a valid octal number and splits it into four +# strings: the sign of the significand, the absolute value of the significand, +# the sign of the exponent, and the absolute value of the exponent. The +# significand is in base 8, and the exponent is in base 2. + +sub _oct_str_to_oct_str_parts { + my $class = shift; + my $str = shift; + + if ($str =~ / + ^ + + # optional leading whitespace + \s* + + # optional sign + ( [+-]? ) + + # optional octal prefix + (?: 0? [Oo] _* )? + + # significand using the octal digits 0..7 + ( + # integer part and optional fraction part ... + [0-7]+ (?: _+ [0-7]+ )* _* + (?: + \. + (?: _* [0-7]+ (?: _+ [0-7]+ )* _* )? + )? + | + # ... or mandatory fraction part + \. + [0-7]+ (?: _+ [0-7]+ )* _* + ) + + # optional exponent (power of 2) using decimal digits + (?: + [Pp] + ( [+-]? ) + ( \d+ (?: _+ \d+ )* _* ) + )? + + # optional trailing whitespace + \s* + + $ + /x) + { + return $class -> _trim_split_parts($1, $2, $3, $4); + } + + return; +} + +# Takes any string representing a valid binary number and splits it into four +# strings: the sign of the significand, the absolute value of the significand, +# the sign of the exponent, and the absolute value of the exponent. The +# significand is in base 2, and the exponent is in base 2. + +sub _bin_str_to_bin_str_parts { + my $class = shift; + my $str = shift; + + if ($str =~ / + ^ + + # optional leading whitespace + \s* + + # optional sign + ( [+-]? ) + + # optional binary prefix + (?: 0? [Bb] _* )? + + # significand using the binary digits 0 and 1 + ( + # integer part and optional fraction part ... + [01]+ (?: _+ [01]+ )* _* + (?: + \. + (?: _* [01]+ (?: _+ [01]+ )* _* )? + )? + | + # ... or mandatory fraction part + \. + [01]+ (?: _+ [01]+ )* _* + ) + + # optional exponent (power of 2) using decimal digits + (?: + [Pp] + ( [+-]? ) + ( \d+ (?: _+ \d+ )* _* ) + )? + + # optional trailing whitespace + \s* + + $ + /x) + { + return $class -> _trim_split_parts($1, $2, $3, $4); + } + + return; +} + +# Takes any string representing a valid decimal number and splits it into four +# parts: the sign of the significand, the absolute value of the significand as a +# libray thingy, the sign of the exponent, and the absolute value of the +# exponent as a library thingy. + +sub _dec_str_parts_to_flt_lib_parts { + shift; # class name + + my ($sig_sgn, $sig_str, $exp_sgn, $exp_str) = @_; + + # Handle zero. + + if ($sig_str eq '0') { + return '+', $LIB -> _zero(), '+', $LIB -> _zero(); + } + + # Absolute value of exponent as library "object". + + my $exp_lib = $LIB -> _new($exp_str); + + # If there is a dot in the significand, remove it so the significand + # becomes an integer and adjust the exponent accordingly. Also remove + # leading zeros which might now appear in the significand. E.g., + # + # 12.345e-2 -> 12345e-5 + # 12.345e+2 -> 12345e-1 + # 0.0123e+5 -> 00123e+1 -> 123e+1 + + my $idx = index $sig_str, '.'; + if ($idx >= 0) { + substr($sig_str, $idx, 1) = ''; + + # delta = length - index + my $delta = $LIB -> _new(CORE::length($sig_str)); + $delta = $LIB -> _sub($delta, $LIB -> _new($idx)); + + # exponent - delta + ($exp_lib, $exp_sgn) = $LIB -> _ssub($exp_lib, $exp_sgn, $delta, '+'); + + $sig_str =~ s/^0+//; + } + + # If there are trailing zeros in the significand, remove them and + # adjust the exponent. E.g., + # + # 12340e-5 -> 1234e-4 + # 12340e-1 -> 1234e0 + # 12340e+3 -> 1234e4 + + if ($sig_str =~ s/(0+)\z//) { + my $len = CORE::length($1); + ($exp_lib, $exp_sgn) = + $LIB -> _sadd($exp_lib, $exp_sgn, $LIB -> _new($len), '+'); + } + + # At this point, the significand is empty or an integer with no trailing + # zeros. The exponent is in base 10. + + unless (CORE::length $sig_str) { + return '+', $LIB -> _zero(), '+', $LIB -> _zero(); + } + + # Absolute value of significand as library "object". + + my $sig_lib = $LIB -> _new($sig_str); + + return $sig_sgn, $sig_lib, $exp_sgn, $exp_lib; +} + +# Takes any string representing a valid binary number and splits it into four +# parts: the sign of the significand, the absolute value of the significand as a +# libray thingy, the sign of the exponent, and the absolute value of the +# exponent as a library thingy. + +sub _bin_str_parts_to_flt_lib_parts { + shift; # class name + + my ($sig_sgn, $sig_str, $exp_sgn, $exp_str, $bpc) = @_; + my $bpc_lib = $LIB -> _new($bpc); + + # Handle zero. + + if ($sig_str eq '0') { + return '+', $LIB -> _zero(), '+', $LIB -> _zero(); + } + + # Absolute value of exponent as library "object". + + my $exp_lib = $LIB -> _new($exp_str); + + # If there is a dot in the significand, remove it so the significand + # becomes an integer and adjust the exponent accordingly. Also remove + # leading zeros which might now appear in the significand. E.g., with + # hexadecimal numbers + # + # 12.345p-2 -> 12345p-14 + # 12.345p+2 -> 12345p-10 + # 0.0123p+5 -> 00123p-11 -> 123p-11 + + my $idx = index $sig_str, '.'; + if ($idx >= 0) { + substr($sig_str, $idx, 1) = ''; + + # delta = (length - index) * bpc + my $delta = $LIB -> _new(CORE::length($sig_str)); + $delta = $LIB -> _sub($delta, $LIB -> _new($idx)); + $delta = $LIB -> _mul($delta, $bpc_lib) if $bpc != 1; + + # exponent - delta + ($exp_lib, $exp_sgn) = $LIB -> _ssub($exp_lib, $exp_sgn, $delta, '+'); + + $sig_str =~ s/^0+//; + } + + # If there are trailing zeros in the significand, remove them and + # adjust the exponent accordingly. E.g., with hexadecimal numbers + # + # 12340p-5 -> 1234p-1 + # 12340p-1 -> 1234p+3 + # 12340p+3 -> 1234p+7 + + if ($sig_str =~ s/(0+)\z//) { + + # delta = length * bpc + my $delta = $LIB -> _new(CORE::length($1)); + $delta = $LIB -> _mul($delta, $bpc_lib) if $bpc != 1; + + # exponent + delta + ($exp_lib, $exp_sgn) = $LIB -> _sadd($exp_lib, $exp_sgn, $delta, '+'); + } + + # At this point, the significand is empty or an integer with no leading + # or trailing zeros. The exponent is in base 2. + + unless (CORE::length $sig_str) { + return '+', $LIB -> _zero(), '+', $LIB -> _zero(); + } + + # Absolute value of significand as library "object". + + my $sig_lib = $bpc == 1 ? $LIB -> _from_bin('0b' . $sig_str) + : $bpc == 3 ? $LIB -> _from_oct('0' . $sig_str) + : $bpc == 4 ? $LIB -> _from_hex('0x' . $sig_str) + : die "internal error: invalid exponent multiplier"; + + # If the exponent (in base 2) is positive or zero ... + + if ($exp_sgn eq '+') { + + if (!$LIB -> _is_zero($exp_lib)) { + + # Multiply significand by 2 raised to the exponent. + + my $p = $LIB -> _pow($LIB -> _two(), $exp_lib); + $sig_lib = $LIB -> _mul($sig_lib, $p); + $exp_lib = $LIB -> _zero(); + } + } + + # ... else if the exponent is negative ... + + else { + + # Rather than dividing the significand by 2 raised to the absolute + # value of the exponent, multiply the significand by 5 raised to the + # absolute value of the exponent and let the exponent be in base 10: + # + # a * 2^(-b) = a * 5^b * 10^(-b) = c * 10^(-b), where c = a * 5^b + + my $p = $LIB -> _pow($LIB -> _new("5"), $exp_lib); + $sig_lib = $LIB -> _mul($sig_lib, $p); + } + + # Adjust for the case when the conversion to decimal introduced trailing + # zeros in the significand. + + my $n = $LIB -> _zeros($sig_lib); + if ($n) { + $n = $LIB -> _new($n); + $sig_lib = $LIB -> _rsft($sig_lib, $n, 10); + ($exp_lib, $exp_sgn) = $LIB -> _sadd($exp_lib, $exp_sgn, $n, '+'); + } + + return $sig_sgn, $sig_lib, $exp_sgn, $exp_lib; +} + +# Takes any string representing a valid hexadecimal number and splits it into +# four parts: the sign of the significand, the absolute value of the significand +# as a libray thingy, the sign of the exponent, and the absolute value of the +# exponent as a library thingy. + +sub _hex_str_to_flt_lib_parts { + my $class = shift; + my $str = shift; + if (my @parts = $class -> _hex_str_to_hex_str_parts($str)) { + return $class -> _bin_str_parts_to_flt_lib_parts(@parts, 4); # 4 bits pr. chr + } + return; +} + +# Takes any string representing a valid octal number and splits it into four +# parts: the sign of the significand, the absolute value of the significand as a +# libray thingy, the sign of the exponent, and the absolute value of the +# exponent as a library thingy. + +sub _oct_str_to_flt_lib_parts { + my $class = shift; + my $str = shift; + if (my @parts = $class -> _oct_str_to_oct_str_parts($str)) { + return $class -> _bin_str_parts_to_flt_lib_parts(@parts, 3); # 3 bits pr. chr + } + return; +} + +# Takes any string representing a valid binary number and splits it into four +# parts: the sign of the significand, the absolute value of the significand as a +# libray thingy, the sign of the exponent, and the absolute value of the +# exponent as a library thingy. + +sub _bin_str_to_flt_lib_parts { + my $class = shift; + my $str = shift; + if (my @parts = $class -> _bin_str_to_bin_str_parts($str)) { + return $class -> _bin_str_parts_to_flt_lib_parts(@parts, 1); # 1 bit pr. chr + } + return; +} + +# Decimal string is split into the sign of the signficant, the absolute value of +# the significand as library thingy, the sign of the exponent, and the absolute +# value of the exponent as a a library thingy. + +sub _dec_str_to_flt_lib_parts { + my $class = shift; + my $str = shift; + if (my @parts = $class -> _dec_str_to_dec_str_parts($str)) { + return $class -> _dec_str_parts_to_flt_lib_parts(@parts); + } + return; +} + +# Hexdecimal string to a string using decimal floating point notation. + +sub hex_str_to_dec_flt_str { + my $class = shift; + my $str = shift; + if (my @parts = $class -> _hex_str_to_flt_lib_parts($str)) { + return $class -> _flt_lib_parts_to_flt_str(@parts); + } + return; +} + +# Octal string to a string using decimal floating point notation. + +sub oct_str_to_dec_flt_str { + my $class = shift; + my $str = shift; + if (my @parts = $class -> _oct_str_to_flt_lib_parts($str)) { + return $class -> _flt_lib_parts_to_flt_str(@parts); + } + return; +} + +# Binary string to a string decimal floating point notation. + +sub bin_str_to_dec_flt_str { + my $class = shift; + my $str = shift; + if (my @parts = $class -> _bin_str_to_flt_lib_parts($str)) { + return $class -> _flt_lib_parts_to_flt_str(@parts); + } + return; +} + +# Decimal string to a string using decimal floating point notation. + +sub dec_str_to_dec_flt_str { + my $class = shift; + my $str = shift; + if (my @parts = $class -> _dec_str_to_flt_lib_parts($str)) { + return $class -> _flt_lib_parts_to_flt_str(@parts); + } + return; +} + +# Hexdecimal string to decimal notation (no exponent). + +sub hex_str_to_dec_str { + my $class = shift; + my $str = shift; + if (my @parts = $class -> _dec_str_to_flt_lib_parts($str)) { + return $class -> _flt_lib_parts_to_dec_str(@parts); + } + return; +} + +# Octal string to decimal notation (no exponent). + +sub oct_str_to_dec_str { + my $class = shift; + my $str = shift; + if (my @parts = $class -> _oct_str_to_flt_lib_parts($str)) { + return $class -> _flt_lib_parts_to_dec_str(@parts); + } + return; +} + +# Binary string to decimal notation (no exponent). + +sub bin_str_to_dec_str { + my $class = shift; + my $str = shift; + if (my @parts = $class -> _bin_str_to_flt_lib_parts($str)) { + return $class -> _flt_lib_parts_to_dec_str(@parts); + } + return; +} + +# Decimal string to decimal notation (no exponent). + +sub dec_str_to_dec_str { + my $class = shift; + my $str = shift; + if (my @parts = $class -> _dec_str_to_flt_lib_parts($str)) { + return $class -> _flt_lib_parts_to_dec_str(@parts); + } + return; +} + +sub _flt_lib_parts_to_flt_str { + my $class = shift; + my @parts = @_; + return $parts[0] . $LIB -> _str($parts[1]) + . 'e' . $parts[2] . $LIB -> _str($parts[3]); +} + +sub _flt_lib_parts_to_dec_str { + my $class = shift; + my @parts = @_; + + # The number is an integer iff the exponent is non-negative. + + if ($parts[2] eq '+') { + my $str = $parts[0] + . $LIB -> _str($LIB -> _lsft($parts[1], $parts[3], 10)); + return $str; + } + + # If it is not an integer, add a decimal point. + + else { + my $mant = $LIB -> _str($parts[1]); + my $mant_len = CORE::length($mant); + my $expo = $LIB -> _num($parts[3]); + my $len_cmp = $mant_len <=> $expo; + if ($len_cmp <= 0) { + return $parts[0] . '0.' . '0' x ($expo - $mant_len) . $mant; + } else { + substr $mant, $mant_len - $expo, 0, '.'; + return $parts[0] . $mant; + } + } +} + +# Takes four arguments, the sign of the significand, the absolute value of the +# significand as a libray thingy, the sign of the exponent, and the absolute +# value of the exponent as a library thingy, and returns three parts: the sign +# of the rational number, the absolute value of the numerator as a libray +# thingy, and the absolute value of the denominator as a library thingy. +# +# For example, to convert data representing the value "+12e-2", then +# +# $sm = "+"; +# $m = $LIB -> _new("12"); +# $se = "-"; +# $e = $LIB -> _new("2"); +# ($sr, $n, $d) = $class -> _flt_lib_parts_to_rat_lib_parts($sm, $m, $se, $e); +# +# returns data representing the same value written as the fraction "+3/25" +# +# $sr = "+" +# $n = $LIB -> _new("3"); +# $d = $LIB -> _new("12"); + +sub _flt_lib_parts_to_rat_lib_parts { + my $self = shift; + my ($msgn, $mabs, $esgn, $eabs) = @_; + + if ($esgn eq '-') { # "12e-2" -> "12/100" -> "3/25" + my $num_lib = $LIB -> _copy($mabs); + my $den_lib = $LIB -> _1ex($LIB -> _num($eabs)); + my $gcd_lib = $LIB -> _gcd($LIB -> _copy($num_lib), $den_lib); + $num_lib = $LIB -> _div($LIB -> _copy($num_lib), $gcd_lib); + $den_lib = $LIB -> _div($den_lib, $gcd_lib); + return $msgn, $num_lib, $den_lib; + } + + elsif (!$LIB -> _is_zero($eabs)) { # "12e+2" -> "1200" -> "1200/1" + return $msgn, $LIB -> _lsft($LIB -> _copy($mabs), $eabs, 10), + $LIB -> _one(); + } + + else { # "12e+0" -> "12" -> "12/1" + return $msgn, $mabs, $LIB -> _one(); + } +} + +# Add the function _register_callback() to Math::BigInt. It is provided for +# backwards compabibility so that old version of Math::BigRat etc. don't +# complain about missing it. + +sub _register_callback { } + ############################################################################### # this method returns 0 if the object can be modified, or 1 if not. # We use a fast constant sub() here, to avoid costly calls. Subclasses @@ -4437,7 +5828,7 @@ __END__ =head1 NAME -Math::BigInt - Arbitrary size integer/float math package +Math::BigInt - arbitrary size integer math package =head1 SYNOPSIS @@ -4448,19 +5839,15 @@ Math::BigInt - Arbitrary size integer/float math package # pure Perl if the GMP library is not installed): # (See also the L<MATH LIBRARY> section!) - # warns if Math::BigInt::GMP cannot be found + # to warn if Math::BigInt::GMP cannot be found, use use Math::BigInt lib => 'GMP'; - # to suppress the warning use this: + # to suppress the warning if Math::BigInt::GMP cannot be found, use # use Math::BigInt try => 'GMP'; - # dies if GMP cannot be loaded: + # to die if Math::BigInt::GMP cannot be found, use # use Math::BigInt only => 'GMP'; - my $str = '1234567890'; - my @values = (64, 74, 18); - my $n = 1; my $sign = '-'; - # Configuration methods (may be used as class methods and instance methods) Math::BigInt->accuracy(); # get class accuracy @@ -4483,6 +5870,7 @@ Math::BigInt - Arbitrary size integer/float math package $x = Math::BigInt->from_oct('377'); # from octal $x = Math::BigInt->from_bin('1101'); # from binary $x = Math::BigInt->from_base('why', 36); # from any base + $x = Math::BigInt->from_base_num([1, 0], 2); # from any base $x = Math::BigInt->bzero(); # create a +0 $x = Math::BigInt->bone(); # create a +1 $x = Math::BigInt->bone('-'); # create a -1 @@ -4491,8 +5879,10 @@ Math::BigInt - Arbitrary size integer/float math package $x = Math::BigInt->bnan(); # create a Not-A-Number $x = Math::BigInt->bpi(); # returns pi - $y = $x->copy(); # make a copy (unlike $y = $x) - $y = $x->as_int(); # return as a Math::BigInt + $y = $x->copy(); # make a copy (unlike $y = $x) + $y = $x->as_int(); # return as a Math::BigInt + $y = $x->as_float(); # return as a Math::BigFloat + $y = $x->as_rat(); # return as a Math::BigRat # Boolean methods (these don't modify the invocand) @@ -4559,6 +5949,9 @@ Math::BigInt - Arbitrary size integer/float math package $x->bsqrt(); # calculate square root $x->broot($y); # $y'th root of $x (e.g. $y == 3 => cubic root) $x->bfac(); # factorial of $x (1*2*3*4*..$x) + $x->bdfac(); # double factorial of $x ($x*($x-2)*($x-4)*...) + $x->btfac(); # triple factorial of $x ($x*($x-3)*($x-6)*...) + $x->bmfac($k); # $k'th multi-factorial of $x ($x*($x-$k)*...) $x->blsft($n); # left shift $n places in base 2 $x->blsft($n,$b); # left shift $n places in base $b @@ -4605,6 +5998,9 @@ Math::BigInt - Arbitrary size integer/float math package $x->nparts(); # mantissa and exponent (normalised) $x->eparts(); # mantissa and exponent (engineering notation) $x->dparts(); # integer and fraction part + $x->fparts(); # numerator and denominator + $x->numerator(); # numerator + $x->denominator(); # denominator # Conversion methods (do not modify the invocand) @@ -4612,13 +6008,14 @@ Math::BigInt - Arbitrary size integer/float math package $x->bsstr(); # string in scientific notation with integers $x->bnstr(); # string in normalized notation $x->bestr(); # string in engineering notation - $x->bdstr(); # string in decimal notation + $x->bfstr(); # string in fractional notation $x->to_hex(); # as signed hexadecimal string $x->to_bin(); # as signed binary string $x->to_oct(); # as signed octal string $x->to_bytes(); # as byte string $x->to_base($b); # as string in any base + $x->to_base_num($b); # as array of integers in any base $x->as_hex(); # as signed hexadecimal string with prefixed 0x $x->as_bin(); # as signed binary string with prefixed 0b @@ -4636,7 +6033,9 @@ also provided for Perl operators. =head2 Input Input values to these routines may be any scalar number or string that looks -like a number and represents an integer. +like a number and represents an integer. Anything that is accepted by Perl as a +literal numeric constant should be accepted by this module, except that finite +non-integers return NaN. =over @@ -4646,53 +6045,86 @@ Leading and trailing whitespace is ignored. =item * -Leading and trailing zeros are ignored. +Leading zeros are ignored, except for floating point numbers with a binary +exponent, in which case the number is interpreted as an octal floating point +number. For example, "01.4p+0" gives 1.5, "00.4p+0" gives 0.5, but "0.4p+0" +gives a NaN. And while "0377" gives 255, "0377p0" gives 255. =item * -If the string has a "0x" prefix, it is interpreted as a hexadecimal number. +If the string has a "0x" or "0X" prefix, it is interpreted as a hexadecimal +number. =item * -If the string has a "0b" prefix, it is interpreted as a binary number. +If the string has a "0o" or "0O" prefix, it is interpreted as an octal number. A +floating point literal with a "0" prefix is also interpreted as an octal number. =item * -One underline is allowed between any two digits. +If the string has a "0b" or "0B" prefix, it is interpreted as a binary number. =item * -If the string can not be interpreted, NaN is returned. +Underline characters are allowed in the same way as they are allowed in literal +numerical constants. -=back +=item * -Octal numbers are typically prefixed by "0", but since leading zeros are -stripped, these methods can not automatically recognize octal numbers, so use -the constructor from_oct() to interpret octal strings. +If the string can not be interpreted, or does not represent a finite integer, +NaN is returned. + +=item * + +For hexadecimal, octal, and binary floating point numbers, the exponent must be +separated from the significand (mantissa) by the letter "p" or "P", not "e" or +"E" as with decimal numbers. + +=back Some examples of valid string input Input string Resulting value + 123 123 1.23e2 123 12300e-2 123 - 0xcafe 51966 - 0b1101 13 + 67_538_754 67538754 -4_5_6.7_8_9e+0_1_0 -4567890000000 + 0x13a 314 + 0x13ap0 314 + 0x1.3ap+8 314 + 0x0.00013ap+24 314 + 0x13a000p-12 314 + + 0o472 314 + 0o1.164p+8 314 + 0o0.0001164p+20 314 + 0o1164000p-10 314 + + 0472 472 Note! + 01.164p+8 314 + 00.0001164p+20 314 + 01164000p-10 314 + + 0b100111010 314 + 0b1.0011101p+8 314 + 0b0.00010011101p+12 314 + 0b100111010000p-3 314 + Input given as scalar numbers might lose precision. Quote your input to ensure that no digits are lost: $x = Math::BigInt->new( 56789012345678901234 ); # bad $x = Math::BigInt->new('56789012345678901234'); # good -Currently, Math::BigInt->new() defaults to 0, while Math::BigInt->new('') -results in 'NaN'. This might change in the future, so use always the following -explicit forms to get a zero or NaN: +Currently, C<Math::BigInt->new()> (no input argument) and +C<Math::BigInt->new("")> return 0. This might change in the future, so always +use the following explicit forms to get a zero: $zero = Math::BigInt->bzero(); - $nan = Math::BigInt->bnan(); =head2 Output @@ -4802,18 +6234,25 @@ Set/get the rounding mode. Set/get the class for upgrading. When a computation might result in a non-integer, the operands are upgraded to this class. This is used for instance -by L<bignum>. The default is C<undef>, thus the following operation creates -a Math::BigInt, not a Math::BigFloat: +by L<bignum>. The default is C<undef>, i.e., no upgrading. - my $i = Math::BigInt->new(123); - my $f = Math::BigFloat->new('123.1'); + # with no upgrading + $x = Math::BigInt->new(12); + $y = Math::BigInt->new(5); + print $x / $y, "\n"; # 2 as a Math::BigInt - print $i + $f, "\n"; # prints 246 + # with upgrading to Math::BigFloat + Math::BigInt -> upgrade("Math::BigFloat"); + print $x / $y, "\n"; # 2.4 as a Math::BigFloat + + # with upgrading to Math::BigRat (after loading Math::BigRat) + Math::BigInt -> upgrade("Math::BigRat"); + print $x / $y, "\n"; # 12/5 as a Math::BigRat =item downgrade() -Set/get the class for downgrading. The default is C<undef>. Downgrading is not -done by Math::BigInt. +Set/get the class for downgrading. The default is C<undef>, i.e., no +downgrading. Downgrading is not done by Math::BigInt. =item modify() @@ -4871,11 +6310,18 @@ parameters are marked as RW. The following parameters are supported. $x = Math::BigInt->new($str,$A,$P,$R); Creates a new Math::BigInt object from a scalar or another Math::BigInt object. -The input is accepted as decimal, hexadecimal (with leading '0x') or binary -(with leading '0b'). +The input is accepted as decimal, hexadecimal (with leading '0x'), octal (with +leading ('0o') or binary (with leading '0b'). See L</Input> for more info on accepted input formats. +=item from_dec() + + $x = Math::BigInt->from_dec("314159"); # input is decimal + +Interpret input as a decimal. It is equivalent to new(), but does not accept +anything but strings representing finite, decimal numbers. + =item from_hex() $x = Math::BigInt->from_hex("0xcafe"); # input is hexadecimal @@ -4969,6 +6415,16 @@ are equivalent $x = Math::BigInt->from_base("100", 2, "01"); # $x is 4 $x = Math::BigInt->from_base("|--", 2, "-|"); # $x is 4 +=item from_base_num() + +Returns a new Math::BigInt object given an array of values and a base. This +method is equivalent to C<from_base()>, but works on numbers in an array rather +than characters in a string. Unlike C<from_base()>, all input values may be +arbitrarily large. + + $x = Math::BigInt->from_base_num([1, 1, 0, 1], 2) # $x is 13 + $x = Math::BigInt->from_base_num([3, 125, 39], 128) # $x is 65191 + =item bzero() $x = Math::BigInt->bzero(); @@ -5055,6 +6511,14 @@ v1.22, while C<as_int()> was introduced in v1.68. In Math::BigInt, C<as_int()> has the same effect as C<copy()>. +=item as_float() + +Return the argument as a Math::BigFloat object. + +=item as_rat() + +Return the argument as a Math::BigRat object. + =back =head2 Boolean methods @@ -5539,19 +7003,35 @@ Calculates the N'th root of C<$x>. =item bfac() - $x->bfac(); # factorial of $x (1*2*3*4*..*$x) + $x->bfac(); # factorial of $x -Returns the factorial of C<$x>, i.e., the product of all positive integers up -to and including C<$x>. +Returns the factorial of C<$x>, i.e., $x*($x-1)*($x-2)*...*2*1, the product of +all positive integers up to and including C<$x>. C<$x> must be > -1. The +factorial of N is commonly written as N!, or N!1, when using the multifactorial +notation. =item bdfac() - $x->bdfac(); # double factorial of $x (1*2*3*4*..*$x) + $x->bdfac(); # double factorial of $x + +Returns the double factorial of C<$x>, i.e., $x*($x-2)*($x-4)*... C<$x> must be +> -2. The double factorial of N is commonly written as N!!, or N!2, when using +the multifactorial notation. + +=item btfac() -Returns the double factorial of C<$x>. If C<$x> is an even integer, returns the -product of all positive, even integers up to and including C<$x>, i.e., -2*4*6*...*$x. If C<$x> is an odd integer, returns the product of all positive, -odd integers, i.e., 1*3*5*...*$x. + $x->btfac(); # triple factorial of $x + +Returns the triple factorial of C<$x>, i.e., $x*($x-3)*($x-6)*... C<$x> must be +> -3. The triple factorial of N is commonly written as N!!!, or N!3, when using +the multifactorial notation. + +=item bmfac() + + $x->bmfac($k); # $k'th multifactorial of $x + +Returns the multi-factorial of C<$x>, i.e., $x*($x-$k)*($x-2*$k)*... C<$x> must +be > -$k. The multi-factorial of N is commonly written as N!K. =item bfib() @@ -5847,6 +7327,24 @@ Returns the integer part and the fraction part. If the fraction part can not be represented as an integer, upgrading is performed or NaN is returned. The output of C<dparts()> corresponds to the output from C<bdstr()>. +=item fparts() + +Returns the smallest possible numerator and denominator so that the numerator +divided by the denominator gives back the original value. For finite numbers, +both values are integers. Mnemonic: fraction. + +=item numerator() + +Together with L</denominator()>, returns the smallest integers so that the +numerator divided by the denominator reproduces the original value. With +Math::BigInt, numerator() simply returns a copy of the invocand. + +=item denominator() + +Together with L</numerator()>, returns the smallest integers so that the +numerator divided by the denominator reproduces the original value. With +Math::BigInt, denominator() always returns either a 1 or a NaN. + =back =head2 String conversion methods @@ -5908,6 +7406,17 @@ corresponds to the output from C<dparts()>. 12000 is returned as "12000" 10000 is returned as "10000" +=item bfstr() + +Returns a string representing the number using fractional notation. The output +corresponds to the output from C<fparts()>. + + 12.345 is returned as "2469/200" + 123.45 is returned as "2469/20" + 1234.5 is returned as "2469/2" + 12345 is returned as "12345" + 123450 is returned as "123450" + =item to_hex() $x->to_hex(); @@ -5931,8 +7440,8 @@ Returns an octal string representation of the number. See also from_oct(). $x = Math::BigInt->new("1667327589"); $s = $x->to_bytes(); # $s = "cafe" -Returns a byte string representation of the number using big endian byte -order. The invocand must be a non-negative, finite integer. See also from_bytes(). +Returns a byte string representation of the number using big endian byte order. +The invocand must be a non-negative, finite integer. See also from_bytes(). =item to_base() @@ -5954,6 +7463,19 @@ Here are some more examples See from_base() for information and examples. +=item to_base_num() + +Converts the given number to the given base. This method is equivalent to +C<_to_base()>, but returns numbers in an array rather than characters in a +string. In the output, the first element is the most significant. Unlike +C<_to_base()>, all input values may be arbitrarily large. + + $x = Math::BigInt->new(13); + $x->to_base_num(2); # returns [1, 1, 0, 1] + + $x = Math::BigInt->new(65191); + $x->to_base_num(128); # returns [3, 125, 39] + =item as_hex() $x->as_hex(); @@ -5991,6 +7513,94 @@ needed, for instance in array index operations. =back +=head2 Utility methods + +These utility methods are made public + +=over + +=item dec_str_to_dec_flt_str() + +Takes a string representing any valid number using decimal notation and converts +it to a string representing the same number using decimal floating point +notation. The output consists of five parts joined together: the sign of the +significand, the absolute value of the significand as the smallest possible +integer, the letter "e", the sign of the exponent, and the absolute value of the +exponent. If the input is invalid, nothing is returned. + + $str2 = $class -> dec_str_to_dec_flt_str($str1); + +Some examples + + Input Output + 31400.00e-4 +314e-2 + -0.00012300e8 -123e+2 + 0 +0e+0 + +=item hex_str_to_dec_flt_str() + +Takes a string representing any valid number using hexadecimal notation and +converts it to a string representing the same number using decimal floating +point notation. The output has the same format as that of +L</dec_str_to_dec_flt_str()>. + + $str2 = $class -> hex_str_to_dec_flt_str($str1); + +Some examples + + Input Output + 0xff +255e+0 + +Some examples + +=item oct_str_to_dec_flt_str() + +Takes a string representing any valid number using octal notation and converts +it to a string representing the same number using decimal floating point +notation. The output has the same format as that of +L</dec_str_to_dec_flt_str()>. + + $str2 = $class -> oct_str_to_dec_flt_str($str1); + +=item bin_str_to_dec_flt_str() + +Takes a string representing any valid number using binary notation and converts +it to a string representing the same number using decimal floating point +notation. The output has the same format as that of +L</dec_str_to_dec_flt_str()>. + + $str2 = $class -> bin_str_to_dec_flt_str($str1); + +=item dec_str_to_dec_str() + +Takes a string representing any valid number using decimal notation and converts +it to a string representing the same number using decimal notation. If the +number represents an integer, the output consists of a sign and the absolute +value. If the number represents a non-integer, the output consists of a sign, +the integer part of the number, the decimal point ".", and the fraction part of +the number without any trailing zeros. If the input is invalid, nothing is +returned. + +=item hex_str_to_dec_str() + +Takes a string representing any valid number using hexadecimal notation and +converts it to a string representing the same number using decimal notation. The +output has the same format as that of L</dec_str_to_dec_str()>. + +=item oct_str_to_dec_str() + +Takes a string representing any valid number using octal notation and converts +it to a string representing the same number using decimal notation. The +output has the same format as that of L</dec_str_to_dec_str()>. + +=item bin_str_to_dec_str() + +Takes a string representing any valid number using binary notation and converts +it to a string representing the same number using decimal notation. The output +has the same format as that of L</dec_str_to_dec_str()>. + +=back + =head1 ACCURACY and PRECISION Math::BigInt and Math::BigFloat have full support for accuracy and precision @@ -6182,7 +7792,7 @@ This is how it works now: * You can also set P globally by using Math::SomeClass->precision() likewise. * Globals are classwide, and not inherited by subclasses. - * to undefine A, use Math::SomeCLass->accuracy(undef); + * to undefine A, use Math::SomeClass->accuracy(undef); * to undefine P, use Math::SomeClass->precision(undef); * Setting Math::SomeClass->accuracy() clears automatically Math::SomeClass->precision(), and vice versa. @@ -6217,8 +7827,8 @@ This is how it works now: use Math::BigInt; Math::BigInt->accuracy(2); - Math::BigInt::SomeSubClass->accuracy(3); - $x = Math::BigInt::SomeSubClass->new(1234); + Math::BigInt::SomeSubclass->accuracy(3); + $x = Math::BigInt::SomeSubclass->new(1234); $x is now 1230, and not 1200. A subclass might choose to implement this otherwise, e.g. falling back to the parent's A and P. @@ -6385,52 +7995,80 @@ instead relying on the internal representation. =head2 MATH LIBRARY -Math with the numbers is done (by default) by a module called -C<Math::BigInt::Calc>. This is equivalent to saying: +The mathematical computations are performed by a backend library. It is not +required to specify which backend library to use, but some backend libraries +are much faster than the default library. + +=head3 The default library + +The default library is L<Math::BigInt::Calc>, which is implemented in pure Perl +and hence does not require a compiler. + +=head3 Specifying a library + +The simple case + + use Math::BigInt; + +is equivalent to saying use Math::BigInt try => 'Calc'; -You can change this backend library by using: +You can use a different backend library with, e.g., use Math::BigInt try => 'GMP'; -B<Note>: General purpose packages should not be explicit about the library to -use; let the script author decide which is best. +which attempts to load the L<Math::BigInt::GMP> library, and falls back to the +default library if the specified library can't be loaded. + +Multiple libraries can be specified by separating them by a comma, e.g., + + use Math::BigInt try => 'GMP,Pari'; -If your script works with huge numbers and Calc is too slow for them, you can -also for the loading of one of these libraries and if none of them can be used, -the code dies: +If you request a specific set of libraries and do not allow fallback to the +default library, specify them using "only", use Math::BigInt only => 'GMP,Pari'; -The following would first try to find Math::BigInt::Foo, then -Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc: +If you prefer a specific set of libraries, but want to see a warning if the +fallback library is used, specify them using "lib", - use Math::BigInt try => 'Foo,Math::BigInt::Bar'; + use Math::BigInt lib => 'GMP,Pari'; + +The following first tries to find Math::BigInt::Foo, then Math::BigInt::Bar, and +if this also fails, reverts to Math::BigInt::Calc: -The library that is loaded last is used. Note that this can be overwritten at -any time by loading a different library, and numbers constructed with different -libraries cannot be used in math operations together. + use Math::BigInt try => 'Foo,Math::BigInt::Bar'; -=head3 What library to use? +=head3 Which library to use? B<Note>: General purpose packages should not be explicit about the library to use; let the script author decide which is best. -L<Math::BigInt::GMP> and L<Math::BigInt::Pari> are in cases involving big -numbers much faster than Calc, however it is slower when dealing with very -small numbers (less than about 20 digits) and when converting very large -numbers to decimal (for instance for printing, rounding, calculating their -length in decimal etc). +L<Math::BigInt::GMP>, L<Math::BigInt::Pari>, and L<Math::BigInt::GMPz> are in +cases involving big numbers much faster than L<Math::BigInt::Calc>. However +these libraries are slower when dealing with very small numbers (less than about +20 digits) and when converting very large numbers to decimal (for instance for +printing, rounding, calculating their length in decimal etc.). So please select carefully what library you want to use. -Different low-level libraries use different formats to store the numbers. -However, you should B<NOT> depend on the number having a specific format -internally. +Different low-level libraries use different formats to store the numbers, so +mixing them won't work. You should not depend on the number having a specific +internal format. See the respective math library module documentation for further details. +=head3 Loading multiple libraries + +The first library that is successfully loaded is the one that will be used. Any +further attempts at loading a different module will be ignored. This is to avoid +the situation where module A requires math library X, and module B requires math +library Y, causing modules A and B to be incompatible. For example, + + use Math::BigInt; # loads default "Calc" + use Math::BigFloat only => "GMP"; # ignores "GMP" + =head2 SIGN The sign is either '+', '-', 'NaN', '+inf' or '-inf'. @@ -6452,7 +8090,7 @@ when dividing any negative number by 0. $x = Math::BigInt->babs("-12345"); # Math::BigInt "12345" $x = Math::BigInt->bnorm("-0.00"); # Math::BigInt "0" $x = bigint(1) + bigint(2); # Math::BigInt "3" - $x = bigint(1) + "2"; # ditto (auto-Math::BigIntify of "2") + $x = bigint(1) + "2"; # ditto ("2" becomes a Math::BigInt) $x = bigint(1); # Math::BigInt "1" $x = $x + 5 / 2; # Math::BigInt "3" $x = $x ** 3; # Math::BigInt "27" @@ -6491,49 +8129,69 @@ Examples for converting: my $x = Math::BigInt->new('0b1'.'01' x 123); print "bin: ",$x->as_bin()," hex:",$x->as_hex()," dec: ",$x,"\n"; -=head1 Autocreating constants +=head1 NUMERIC LITERALS -After C<use Math::BigInt ':constant'> all the B<integer> decimal, hexadecimal -and binary constants in the given scope are converted to C<Math::BigInt>. This -conversion happens at compile time. +After C<use Math::BigInt ':constant'> all numeric literals in the given scope +are converted to C<Math::BigInt> objects. This conversion happens at compile +time. Every non-integer is convert to a NaN. -In particular, +For example, - perl -MMath::BigInt=:constant -e 'print 2**100,"\n"' + perl -MMath::BigInt=:constant -le 'print 2**150' -prints the integer value of C<2**100>. Note that without conversion of -constants the expression 2**100 is calculated using Perl scalars. +prints the exact value of C<2**150>. Note that without conversion of constants +to objects the expression C<2**150> is calculated using Perl scalars, which +leads to an inaccurate result. -Please note that strings and floating point constants are not affected, so that +Please note that strings are not affected, so that use Math::BigInt qw/:constant/; - $x = 1234567890123456789012345678901234567890 - + 123456789123456789; - $y = '1234567890123456789012345678901234567890' - + '123456789123456789'; + $x = "1234567890123456789012345678901234567890" + + "123456789123456789"; -does not give you what you expect. You need an explicit Math::BigInt->new() -around one of the operands. You should also quote large constants to protect +does give you what you expect. You need an explicit Math::BigInt->new() around +at least one of the operands. You should also quote large constants to prevent loss of precision: use Math::BigInt; - $x = Math::BigInt->new('1234567889123456789123456789123456789'); + $x = Math::BigInt->new("1234567889123456789123456789123456789"); + +Without the quotes Perl first converts the large number to a floating point +constant at compile time, and then converts the result to a Math::BigInt object +at run time, which results in an inaccurate result. + +=head2 Hexadecimal, octal, and binary floating point literals + +Perl (and this module) accepts hexadecimal, octal, and binary floating point +literals, but use them with care with Perl versions before v5.32.0, because some +versions of Perl silently give the wrong result. Below are some examples of +different ways to write the number decimal 314. -Without the quotes Perl would convert the large number to a floating point -constant at compile time and then hand the result to Math::BigInt, which -results in an truncated result or a NaN. +Hexadecimal floating point literals: -This also applies to integers that look like floating point constants: + 0x1.3ap+8 0X1.3AP+8 + 0x1.3ap8 0X1.3AP8 + 0x13a0p-4 0X13A0P-4 - use Math::BigInt ':constant'; +Octal floating point literals (with "0" prefix): - print ref(123e2),"\n"; - print ref(123.2e2),"\n"; + 01.164p+8 01.164P+8 + 01.164p8 01.164P8 + 011640p-4 011640P-4 -prints nothing but newlines. Use either L<bignum> or L<Math::BigFloat> to get -this to work. +Octal floating point literals (with "0o" prefix) (requires v5.34.0): + + 0o1.164p+8 0O1.164P+8 + 0o1.164p8 0O1.164P8 + 0o11640p-4 0O11640P-4 + +Binary floating point literals: + + 0b1.0011101p+8 0B1.0011101P+8 + 0b1.0011101p8 0B1.0011101P8 + 0b10011101000p-2 0B10011101000P-2 =head1 PERFORMANCE @@ -6727,11 +8385,12 @@ strings: use Test::More tests => 3; use Math::BigInt; - $x = Math::BigInt->new('1e56'); $y = 1e56; + $x = Math::BigInt->new('1e56'); + $y = 1e56; is($x,$y); # fails - is($x->bsstr(),$y); # okay + is($x->bsstr(), $y); # okay $y = Math::BigInt->new($y); - is($x,$y); # okay + is($x, $y); # okay Alternatively, simply use C<< <=> >> for comparisons, this always gets it right. There is not yet a way to get a number automatically represented as a @@ -6871,17 +8530,13 @@ You can also look for information at: =over 4 -=item * RT: CPAN's request tracker - -L<https://rt.cpan.org/Public/Dist/Display.html?Name=Math-BigInt> - -=item * AnnoCPAN: Annotated CPAN documentation +=item * GitHub -L<http://annocpan.org/dist/Math-BigInt> +L<https://github.com/pjacklam/p5-Math-BigInt> -=item * CPAN Ratings +=item * RT: CPAN's request tracker -L<https://cpanratings.perl.org/dist/Math-BigInt> +L<https://rt.cpan.org/Dist/Display.html?Name=Math-BigInt> =item * MetaCPAN @@ -6891,6 +8546,10 @@ L<https://metacpan.org/release/Math-BigInt> L<http://matrix.cpantesters.org/?dist=Math-BigInt> +=item * CPAN Ratings + +L<https://cpanratings.perl.org/dist/Math-BigInt> + =item * The Bignum mailing list =over 4 @@ -6942,7 +8601,7 @@ Florian Ragwitz E<lt>flora@cpan.orgE<gt>, 2010. =item * -Peter John Acklam E<lt>pjacklam@online.noE<gt>, 2011-. +Peter John Acklam E<lt>pjacklam@gmail.comE<gt>, 2011-. =back 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 cd8f1ee44e..a5429dce62 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Calc.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Calc.pm @@ -7,89 +7,171 @@ use warnings; use Carp qw< carp croak >; use Math::BigInt::Lib; -our $VERSION = '1.999818'; +our $VERSION = '1.999837'; +$VERSION =~ tr/_//d; our @ISA = ('Math::BigInt::Lib'); # 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 / $BASE); $i = $i % $BASE; -# This works on x86, but fails on ARM (SA1100, iPAQ) due to who knows what -# reasons. So, use this instead (slower, but correct): -# $i = $i * $y + $car; $car = int($i / $BASE); $i -= $BASE * $car; - ############################################################################## # global constants, flags and accessory # constants for easier life -my ($BASE, $BASE_LEN, $RBASE, $MAX_VAL); -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, related values. - # Used only by the testsuite, the set variant is used only by the BEGIN - # block below: - - my ($class, $b, $int) = @_; - if (defined $b) { - no warnings "redefine"; - - if ($] >= 5.008 && $int && $b > 7) { - $BASE_LEN = $b; - *_mul = \&_mul_use_div_64; - *_div = \&_div_use_div_64; - $BASE = int("1e" . $BASE_LEN); - $MAX_VAL = $BASE-1; - return $BASE_LEN unless wantarray; - return ($BASE_LEN, $BASE, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN, $MAX_VAL); - } +my $MAX_EXP_F; # the maximum possible base 10 exponent with "no integer" +my $MAX_EXP_I; # the maximum possible base 10 exponent with "use integer" + +my $MAX_BITS; # the maximum possible number of bits for $AND_BITS etc. + +my $BASE_LEN; # the current base exponent in use +my $USE_INT; # whether "use integer" is used in the computations + +my $BASE; # the current base, e.g., 10000 if $BASE_LEN is 5 +my $MAX_VAL; # maximum value for an element, i.e., $BASE - 1 + +my $AND_BITS; # maximum value used in binary and, e.g., 0xffff +my $OR_BITS; # ditto for binary or +my $XOR_BITS; # ditto for binary xor + +my $AND_MASK; # $AND_BITS + 1, e.g., 0x10000 if $AND_BITS is 0xffff +my $OR_MASK; # ditto for binary or +my $XOR_MASK; # ditto for binary xor + +sub config { + my $self = shift; - # find whether we can use mul or div in mul()/div() - $BASE_LEN = $b + 1; - my $caught = 0; - while (--$BASE_LEN > 5) { - $BASE = int("1e" . $BASE_LEN); - $RBASE = abs('1e-' . $BASE_LEN); # see USE_MUL - $caught = 0; - $caught += 1 if (int($BASE * $RBASE) != 1); # should be 1 - $caught += 2 if (int($BASE / $BASE) != 1); # should be 1 - last if $caught != 3; + croak "Missing input argument" unless @_; + + # Called as a getter. + + if (@_ == 1) { + my $param = shift; + croak "Parameter name must be a non-empty string" + unless defined $param && length $param; + return $BASE_LEN if $param eq 'base_len'; + return $USE_INT if $param eq 'use_int'; + croak "Unknown parameter '$param'"; + } + + # Called as a setter. + + my $opts; + while (@_) { + my $param = shift; + croak "Parameter name must be a non-empty string" + unless defined $param && length $param; + croak "Missing value for parameter '$param'" + unless @_; + my $value = shift; + + if ($param eq 'base_len' || $param eq 'use_int') { + $opts -> {$param} = $value; + next; } - $BASE = int("1e" . $BASE_LEN); - $RBASE = abs('1e-' . $BASE_LEN); # see USE_MUL - $MAX_VAL = $BASE-1; - # ($caught & 1) != 0 => cannot use MUL - # ($caught & 2) != 0 => cannot use DIV - if ($caught == 2) # 2 + croak "Unknown parameter '$param'"; + } + + $BASE_LEN = $opts -> {base_len} if exists $opts -> {base_len}; + $USE_INT = $opts -> {use_int} if exists $opts -> {use_int}; + __PACKAGE__ -> _base_len($BASE_LEN, $USE_INT); + + return $self; +} + +sub _base_len { + #my $class = shift; # $class is not used + shift; + + if (@_) { # if called as setter ... + my ($base_len, $use_int) = @_; + + croak "The base length must be a positive integer" + unless defined($base_len) && $base_len == int($base_len) + && $base_len > 0; + + if ( $use_int && ($base_len > $MAX_EXP_I) || + !$use_int && ($base_len > $MAX_EXP_F)) { - # must USE_MUL since we cannot use DIV - *_mul = \&_mul_use_mul; - *_div = \&_div_use_mul; - } else # 0 or 1 + croak "The maximum base length (exponent) is $MAX_EXP_I with", + " 'use integer' and $MAX_EXP_F without 'use integer'. The", + " requested settings, a base length of $base_len ", + $use_int ? "with" : "without", " 'use integer', is invalid."; + } + + $BASE_LEN = $base_len; + $BASE = 0 + ("1" . ("0" x $BASE_LEN)); + $MAX_VAL = $BASE - 1; + $USE_INT = $use_int ? 1 : 0; + { - # can USE_DIV instead - *_mul = \&_mul_use_div; - *_div = \&_div_use_div; + no warnings "redefine"; + if ($use_int) { + *_mul = \&_mul_use_int; + *_div = \&_div_use_int; + } else { + *_mul = \&_mul_no_int; + *_div = \&_div_no_int; + } } } + + # Find max bits. This is the largest power of two that is both no larger + # than $BASE and no larger than the maximum integer (i.e., ~0). We need + # this limitation because _and(), _or(), and _xor() only work on one + # element at a time. + + my $umax = ~0; # largest unsigned integer + my $tmp = $umax < $BASE ? $umax : $BASE; + + $MAX_BITS = 0; + while ($tmp >>= 1) { + $MAX_BITS++; + } + + # Limit to 32 bits for portability. Is this really necessary? XXX + + $MAX_BITS = 32 if $MAX_BITS > 32; + + # Find out how many bits _and, _or and _xor can take (old default = 16). + # Are these tests really necessary? Can't we just use $MAX_BITS? XXX + + for ($AND_BITS = $MAX_BITS ; $AND_BITS > 0 ; $AND_BITS--) { + my $x = CORE::oct('0b' . '1' x $AND_BITS); + my $y = $x & $x; + my $z = 2 * (2 ** ($AND_BITS - 1)) + 1; + last unless $AND_BITS < $MAX_BITS && $x == $z && $y == $x; + } + + for ($XOR_BITS = $MAX_BITS ; $XOR_BITS > 0 ; $XOR_BITS--) { + my $x = CORE::oct('0b' . '1' x $XOR_BITS); + my $y = $x ^ $x; + my $z = 2 * (2 ** ($XOR_BITS - 1)) + 1; + last unless $XOR_BITS < $MAX_BITS && $x == $z && $y == $x; + } + + for ($OR_BITS = $MAX_BITS ; $OR_BITS > 0 ; $OR_BITS--) { + my $x = CORE::oct('0b' . '1' x $OR_BITS); + my $y = $x | $x; + my $z = 2 * (2 ** ($OR_BITS - 1)) + 1; + last unless $OR_BITS < $MAX_BITS && $x == $z && $y == $x; + } + + $AND_MASK = __PACKAGE__->_new(( 2 ** $AND_BITS )); + $XOR_MASK = __PACKAGE__->_new(( 2 ** $XOR_BITS )); + $OR_MASK = __PACKAGE__->_new(( 2 ** $OR_BITS )); + return $BASE_LEN unless wantarray; - return ($BASE_LEN, $BASE, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN, $MAX_VAL); + return ($BASE_LEN, $BASE, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN, $MAX_VAL, + $MAX_BITS, $MAX_EXP_F, $MAX_EXP_I, $USE_INT); } sub _new { @@ -116,89 +198,98 @@ sub _new { } 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; - $num *= $num + 1; - } 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) - - my $int = 0; - if ($e > 7) { - use integer; - my $e1 = 7; - $num = 7; - do { - $num = ('9' x ++$e1) + 0; - $num *= $num + 1; - } while ("$num" =~ /9{$e1}0{$e1}/); # must be a certain pattern - $e1--; # last test failed, so retract one step - if ($e1 > 7) { - $int = 1; - $e = $e1; - } - } - __PACKAGE__ -> _base_len($e, $int); # set and store + # Compute $MAX_EXP_F, the maximum usable base 10 exponent. - 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 = CORE::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 = CORE::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 = CORE::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 )); - - # We can compute the approximate length no faster than the real length: - *_alen = \&_len; + # The largest element in base 10**$BASE_LEN is 10**$BASE_LEN-1. For instance, + # with $BASE_LEN = 5, the largest element is 99_999, and the largest carry is + # + # int( 99_999 * 99_999 / 100_000 ) = 99_998 + # + # so make sure that 99_999 * 99_999 + 99_998 is within the range of integers + # that can be represented accuratly. + # + # Note that on some systems with quadmath support, the following is within + # the range of numbers that can be represented exactly, but it still gives + # the incorrect value $r = 2 (even though POSIX::fmod($x, $y) gives the + # correct value of 1: + # + # $x = 99999999999999999; + # $y = 100000000000000000; + # $r = $x * $x % $y; # should be 1 + # + # so also check for this. + + for ($MAX_EXP_F = 1 ; ; $MAX_EXP_F++) { # when $MAX_EXP_F = 5 + my $MAX_EXP_FM1 = $MAX_EXP_F - 1; # = 4 + my $bs = "1" . ("0" x $MAX_EXP_F); # = "100000" + my $xs = "9" x $MAX_EXP_F; # = "99999" + my $cs = ("9" x $MAX_EXP_FM1) . "8"; # = "99998" + my $ys = $cs . ("0" x $MAX_EXP_FM1) . "1"; # = "9999800001" + + # Compute and check the product. + my $yn = $xs * $xs; # = 9999800001 + last if $yn != $ys; + + # Compute and check the remainder. + my $rn = $yn % $bs; # = 1 + last if $rn != 1; + + # Compute and check the carry. The division here is exact. + my $cn = ($yn - $rn) / $bs; # = 99998 + last if $cn != $cs; + + # Compute and check product plus carry. + my $zs = $cs . ("9" x $MAX_EXP_F); # = "9999899999" + my $zn = $yn + $cn; # = 99998999999 + last if $zn != $zs; + last if $zn - ($zn - 1) != 1; + } + $MAX_EXP_F--; # last test failed, so retract one step + + # Compute $MAX_EXP_I, the maximum usable base 10 exponent within the range + # of what is available with "use integer". On older versions of Perl, + # integers are converted to floating point numbers, even though they are + # within the range of what can be represented as integers. For example, on + # some 64 bit Perls, 999999999 * 999999999 becomes 999999998000000000, not + # 999999998000000001, even though the latter is less than the maximum value + # for a 64 bit integer, 18446744073709551615. + + my $umax = ~0; # largest unsigned integer + for ($MAX_EXP_I = int(0.5 * log($umax) / log(10)); + $MAX_EXP_I > 0; + $MAX_EXP_I--) + { # when $MAX_EXP_I = 5 + my $MAX_EXP_IM1 = $MAX_EXP_I - 1; # = 4 + my $bs = "1" . ("0" x $MAX_EXP_I); # = "100000" + my $xs = "9" x $MAX_EXP_I; # = "99999" + my $cs = ("9" x $MAX_EXP_IM1) . "8"; # = "99998" + my $ys = $cs . ("0" x $MAX_EXP_IM1) . "1"; # = "9999800001" + + # Compute and check the product. + my $yn = $xs * $xs; # = 9999800001 + next if $yn != $ys; + + # Compute and check the remainder. + my $rn = $yn % $bs; # = 1 + next if $rn != 1; + + # Compute and check the carry. The division here is exact. + my $cn = ($yn - $rn) / $bs; # = 99998 + next if $cn != $cs; + + # Compute and check product plus carry. + my $zs = $cs . ("9" x $MAX_EXP_I); # = "9999899999" + my $zn = $yn + $cn; # = 99998999999 + next if $zn != $zs; + next if $zn - ($zn - 1) != 1; + last; + } + + ($BASE_LEN, $USE_INT) = $MAX_EXP_F > $MAX_EXP_I + ? ($MAX_EXP_F, 0) : ($MAX_EXP_I, 1); + + __PACKAGE__ -> _base_len($BASE_LEN, $USE_INT); } ############################################################################### @@ -224,18 +315,20 @@ sub _two { sub _ten { # create a 10 my $class = shift; - bless [ 10 ], $class; + my $self = $BASE_LEN == 1 ? [ 0, 1 ] : [ 10 ]; + bless $self, $class; } sub _1ex { # create a 1Ex my $class = shift; - my $rem = $_[0] % $BASE_LEN; # remainder - my $parts = $_[0] / $BASE_LEN; # parts + my $rem = $_[0] % $BASE_LEN; # remainder + my $div = ($_[0] - $rem) / $BASE_LEN; # parts - # 000000, 000000, 100 - bless [ (0) x $parts, '1' . ('0' x $rem) ], $class; + # With a $BASE_LEN of 6, 1e14 becomes + # [ 000000, 000000, 100 ] -> [ 0, 0, 100 ] + bless [ (0) x $div, 0 + ("1" . ("0" x $rem)) ], $class; } sub _copy { @@ -244,8 +337,33 @@ sub _copy { return bless [ @{ $_[0] } ], $class; } -# catch and throw away -sub import { } +sub import { + my $self = shift; + + my $opts; + my ($base_len, $use_int); + while (@_) { + my $param = shift; + croak "Parameter name must be a non-empty string" + unless defined $param && length $param; + croak "Missing value for parameter '$param'" + unless @_; + my $value = shift; + + if ($param eq 'base_len' || $param eq 'use_int') { + $opts -> {$param} = $value; + next; + } + + croak "Unknown parameter '$param'"; + } + + $base_len = exists $opts -> {base_len} ? $opts -> {base_len} : $BASE_LEN; + $use_int = exists $opts -> {use_int} ? $opts -> {use_int} : $USE_INT; + __PACKAGE__ -> _base_len($base_len, $use_int); + + return $self; +} ############################################################################## # convert back to string and number @@ -319,10 +437,10 @@ sub _add { # 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) { + for my $i (@$y) { $x->[$j] -= $BASE if $car = (($x->[$j] += $i + $car) >= $BASE) ? 1 : 0; $j++; } @@ -368,10 +486,9 @@ sub _sub { my ($c, $sx, $sy, $s) = @_; my $car = 0; - my $i; my $j = 0; if (!$s) { - for $i (@$sx) { + for my $i (@$sx) { last unless defined $sy->[$j] || $car; $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0); $j++; @@ -379,7 +496,7 @@ sub _sub { # might leave leading zeros, so fix that return __strip_zeros($sx); } - for $i (@$sx) { + for my $i (@$sx) { # We can't do an early out if $x < $y, since we need to copy the high # chunks from $y. Found by Bob Mathews. #last unless defined $sy->[$j] || $car; @@ -391,76 +508,12 @@ sub _sub { __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]) >= $BASE) { - my $rem = $xv->[0] % $BASE; - $xv->[1] = ($xv->[0] - $rem) * $RBASE; - $xv->[0] = $rem; - } - 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; - my $rem; - foreach my $i (@$xv) { - $i = $i * $y + $car; - $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 = $c->_copy($xv) if $xv == $yv; # same references? - - my @prod = (); - 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; - for $yi (@$yv) { - $prod = $xi * $yi + ($prod[$cty] || 0) + $car; - $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 - } - push @$xv, @prod; - $xv; -} - -sub _mul_use_div_64 { +sub _mul_use_int { # (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 # works for 64 bit integer with "use integer" my ($c, $xv, $yv) = @_; - use integer; if (@$yv == 1) { @@ -498,13 +551,13 @@ sub _mul_use_div_64 { $yv = $c->_copy($xv) if $xv == $yv; # same references? my @prod = (); - my ($prod, $car, $cty, $xi, $yi); - for $xi (@$xv) { + my ($prod, $car, $cty); + for my $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) { + for my $yi (@$yv) { $prod = $xi * $yi + ($prod[$cty] || 0) + $car; $prod[$cty++] = $prod - ($car = $prod / $BASE) * $BASE; } @@ -515,7 +568,7 @@ sub _mul_use_div_64 { $xv; } -sub _mul_use_div { +sub _mul_no_int { # (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 @@ -559,13 +612,13 @@ sub _mul_use_div { $yv = $c->_copy($xv) if $xv == $yv; # same references? my @prod = (); - my ($prod, $rem, $car, $cty, $xi, $yi); - for $xi (@$xv) { + my ($prod, $rem, $car, $cty); + for my $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) { + for my $yi (@$yv) { $prod = $xi * $yi + ($prod[$cty] || 0) + $car; $rem = $prod % $BASE; $car = ($prod - $rem) / $BASE; @@ -578,166 +631,7 @@ sub _mul_use_div { $xv; } -sub _div_use_mul { - # 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. - - # if both numbers have only one element: - if (@$x == 1 && @$yorg == 1) { - # shortcut, $yorg and $x are two small numbers - 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; - $rem = $c->_mod($c->_copy($x), $yorg) if wantarray; - - # shortcut, $y is < $BASE - my $j = @$x; - my $r = 0; - my $y = $yorg->[0]; - my $b; - while ($j-- > 0) { - $b = $r * $BASE + $x->[$j]; - $r = $b % $y; - $x->[$j] = ($b - $r) / $y; - } - 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 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 - } - - # 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 ($cmp == 0) { # x = y - @$x = 1; - return $x, $c->_zero() if wantarray; - return $x; - } - - if ($cmp < 0) { # x < y - if (wantarray) { - my $rem = $c->_copy($x); - @$x = 0; - return $x, $rem; - } - @$x = 0; - return $x; - } - } - - # all other cases: - - my $y = $c->_copy($yorg); # always make copy to preserve - - 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 - } - push(@$x, $car); - $car = 0; - for my $yi (@$y) { - $yi = $yi * $dd + $car; - $yi -= ($car = int($yi * $RBASE)) * $BASE; # see USE_MUL - } - } else { - push(@$x, 0); - } - - # @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) { - 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; - 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) { - 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); - } - if ($x->[-1] < $car + $bar) { - $car = 0; - --$q; - for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { - $x->[$xi] -= $BASE - if $car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE); - } - } - } - pop(@$x); - unshift(@q, $q); - } - - if (wantarray) { - my $d = bless [], $c; - if ($dd != 1) { - my $car = 0; - my ($prd, $rem); - for my $xi (reverse @$x) { - $prd = $car * $BASE + $xi; - $rem = $prd % $dd; - $tmp = ($prd - $rem) / $dd; - $car = $rem; - unshift @$d, $tmp; - } - } else { - @$d = @$x; - } - @$x = @q; - __strip_zeros($x); - __strip_zeros($d); - return ($x, $d); - } - @$x = @q; - __strip_zeros($x); - $x; -} - -sub _div_use_div_64 { +sub _div_use_int { # ref to array, ref to array, modify first array and return remainder if # in list context @@ -900,7 +794,7 @@ sub _div_use_div_64 { $x; } -sub _div_use_div { +sub _div_no_int { # ref to array, ref to array, modify first array and return remainder if # in list context @@ -1157,12 +1051,12 @@ sub _is_zero { sub _is_even { # return true if arg is even - $_[1]->[0] & 1 ? 0 : 1; + $_[1]->[0] % 2 ? 0 : 1; } sub _is_odd { # return true if arg is odd - $_[1]->[0] & 1 ? 1 : 0; + $_[1]->[0] % 2 ? 1 : 0; } sub _is_one { @@ -1177,7 +1071,11 @@ sub _is_two { sub _is_ten { # return true if arg is ten - @{$_[1]} == 1 && $_[1]->[0] == 10 ? 1 : 0; + if ($BASE_LEN == 1) { + @{$_[1]} == 2 && $_[1]->[0] == 0 && $_[1]->[1] == 1 ? 1 : 0; + } else { + @{$_[1]} == 1 && $_[1]->[0] == 10 ? 1 : 0; + } } sub __strip_zeros { @@ -1316,17 +1214,21 @@ sub _mod { # shifts sub _rsft { - my ($c, $x, $y, $n) = @_; + my ($c, $x, $n, $b) = @_; + 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 ($n != 10) { - $n = $c->_new($n); - return scalar $c->_div($x, $c->_pow($n, $y)); + if ($c -> _acmp($b, $c -> _ten())) { + return scalar $c->_div($x, $c->_pow($c->_copy($b), $n)); } # shortcut (faster) for shifting by 10) # multiples of $BASE_LEN my $dst = 0; # destination - my $src = $c->_num($y); # as normal int + my $src = $c->_num($n); # as normal int my $xlen = (@$x - 1) * $BASE_LEN + length(int($x->[-1])); if ($src >= $xlen or ($src == $xlen and !defined $x->[1])) { # 12345 67890 shifted right by more than 10 digits => 0 @@ -1519,27 +1421,50 @@ sub _nok { return $n; } -my @factorials = ( - 1, - 1, - 2, - 2*3, - 2*3*4, - 2*3*4*5, - 2*3*4*5*6, - 2*3*4*5*6*7, - ); - sub _fac { # factorial of $x # ref to array, return ref to array my ($c, $cx) = @_; - if ((@$cx == 1) && ($cx->[0] <= 7)) { - $cx->[0] = $factorials[$cx->[0]]; # 0 => 1, 1 => 1, 2 => 2 etc. + # We cache the smallest values. Don't assume that a single element has a + # value larger than 9 or else it won't work with a $BASE_LEN of 1. + + if (@$cx == 1) { + my @factorials = + ( + '1', + '1', + '2', + '6', + '24', + '120', + '720', + '5040', + '40320', + '362880', + ); + if ($cx->[0] <= $#factorials) { + my $tmp = $c -> _new($factorials[ $cx->[0] ]); + @$cx = @$tmp; + return $cx; + } + } + + # The old code further below doesn't work for small values of $BASE_LEN. + # Alas, I have not been able to (or taken the time to) decipher it, so for + # the case when $BASE_LEN is small, we call the parent class. This code + # works in for every value of $x and $BASE_LEN. We could use this code for + # all cases, but it is a little slower than the code further below, so at + # least for now we keep the code below. + + if ($BASE_LEN <= 2) { + my $tmp = $c -> SUPER::_fac($cx); + @$cx = @$tmp; return $cx; } + # This code does not work for small values of $BASE_LEN. + if ((@$cx == 1) && # we do this only if $x >= 12 and $x <= 7000 ($cx->[0] >= 12 && $cx->[0] < 7000)) { @@ -1759,9 +1684,9 @@ sub _log_int { $log += (@$base - 1) * $BASE_LEN; # calculate now a guess based on the values obtained above: - my $res = int($len / $log); + my $res = $c->_new(int($len / $log)); - @$x = $res; + @$x = @$res; my $trial = $c->_pow($c->_copy($base), $x); my $acmp = $c->_acmp($trial, $x_org); @@ -1795,9 +1720,8 @@ my $steps = 0; sub steps { $steps }; sub _sqrt { - # square-root of $x in place - # Compute a guess of the result (by rule of thumb), then improve it via - # Newton's method. + # square-root of $x in-place + my ($c, $x) = @_; if (@$x == 1) { @@ -1805,68 +1729,65 @@ sub _sqrt { $x->[0] = int(sqrt($x->[0])); return $x; } - my $y = $c->_copy($x); - # hopefully _len/2 is < $BASE, the -1 is to always undershot the guess - # since our guess will "grow" - my $l = int(($c->_len($x)-1) / 2); - - my $lastelem = $x->[-1]; # for guess - my $elems = @$x - 1; - # not enough digits, but could have more? - if ((length($lastelem) <= 3) && ($elems > 1)) { - # right-align with zero pad - my $len = length($lastelem) & 1; - print "$lastelem => " if DEBUG; - $lastelem .= substr($x->[-2] . '0' x $BASE_LEN, 0, $BASE_LEN); - # former odd => make odd again, or former even to even again - $lastelem = $lastelem / 10 if (length($lastelem) & 1) != $len; - print "$lastelem\n" if DEBUG; - } - - # construct $x (instead of $c->_lsft($x, $l, 10) - my $r = $l % $BASE_LEN; # 10000 00000 00000 00000 ($BASE_LEN=5) - $l = int($l / $BASE_LEN); - print "l = $l " if DEBUG; - - splice @$x, $l; # keep ref($x), but modify it - - # we make the first part of the guess not '1000...0' but int(sqrt($lastelem)) - # that gives us: - # 14400 00000 => sqrt(14400) => guess first digits to be 120 - # 144000 000000 => sqrt(144000) => guess 379 - - print "$lastelem (elems $elems) => " if DEBUG; - $lastelem = $lastelem / 10 if ($elems & 1 == 1); # odd or even? - my $g = sqrt($lastelem); - $g =~ s/\.//; # 2.345 => 2345 - $r -= 1 if $elems & 1 == 0; # 70 => 7 - - # padd with zeros if result is too short - $x->[$l--] = int(substr($g . '0' x $r, 0, $r+1)); - print "now ", $x->[-1] if DEBUG; - print " would have been ", int('1' . '0' x $r), "\n" if DEBUG; - - # If @$x > 1, we could compute the second elem of the guess, too, to create - # an even better guess. Not implemented yet. Does it improve performance? - $x->[$l--] = 0 while ($l >= 0); # all other digits of guess are zero - - print "start x= ", $c->_str($x), "\n" if DEBUG; - my $two = $c->_two(); - my $last = $c->_zero(); - my $lastlast = $c->_zero(); - $steps = 0 if DEBUG; - while ($c->_acmp($last, $x) != 0 && $c->_acmp($lastlast, $x) != 0) { - $steps++ if DEBUG; - $lastlast = $c->_copy($last); - $last = $c->_copy($x); - $c->_add($x, $c->_div($c->_copy($y), $x)); - $c->_div($x, $two ); - print " x= ", $c->_str($x), "\n" if DEBUG; - } - print "\nsteps in sqrt: $steps, " if DEBUG; - $c->_dec($x) if $c->_acmp($y, $c->_mul($c->_copy($x), $x)) < 0; # overshot? - print " final ", $x->[-1], "\n" if DEBUG; - $x; + + # Create an initial guess for the square root. + + my $s; + if (@$x % 2) { + $s = [ (0) x ((@$x - 1) / 2), int(sqrt($x->[-1])) ]; + } else { + $s = [ (0) x ((@$x - 2) / 2), int(sqrt($x->[-2] + $x->[-1] * $BASE)) ]; + } + + # Newton's method for the square root of y: + # + # x(n) * x(n) - y + # x(n+1) = x(n) - ----------------- + # 2 * x(n) + + my $cmp; + while (1) { + my $sq = $c -> _mul($c -> _copy($s), $s); + $cmp = $c -> _acmp($sq, $x); + + # If x(n)*x(n) > y, compute + # + # x(n) * x(n) - y + # x(n+1) = x(n) - ----------------- + # 2 * x(n) + + if ($cmp > 0) { + my $num = $c -> _sub($c -> _copy($sq), $x); + my $den = $c -> _mul($c -> _two(), $s); + my $delta = $c -> _div($num, $den); + last if $c -> _is_zero($delta); + $s = $c -> _sub($s, $delta); + } + + # If x(n)*x(n) < y, compute + # + # y - x(n) * x(n) + # x(n+1) = x(n) + ----------------- + # 2 * x(n) + + elsif ($cmp < 0) { + my $num = $c -> _sub($c -> _copy($x), $sq); + my $den = $c -> _mul($c -> _two(), $s); + my $delta = $c -> _div($num, $den); + last if $c -> _is_zero($delta); + $s = $c -> _add($s, $delta); + } + + # If x(n)*x(n) = y, we have the exact result. + + else { + last; + } + } + + $s = $c -> _dec($s) if $cmp > 0; # never overshoot + @$x = @$s; + return $x; } sub _root { @@ -1876,14 +1797,18 @@ sub _root { # Small numbers. - if (@$x == 1 && @$n == 1) { - # Result can be computed directly. Adjust initial result for numerical - # errors, e.g., int(1000**(1/3)) is 2, not 3. - my $y = int($x->[0] ** (1 / $n->[0])); - my $yp1 = $y + 1; - $y = $yp1 if $yp1 ** $n->[0] == $x->[0]; - $x->[0] = $y; - return $x; + if (@$x == 1) { + return $x if $x -> [0] == 0 || $x -> [0] == 1; + + if (@$n == 1) { + # Result can be computed directly. Adjust initial result for + # numerical errors, e.g., int(1000**(1/3)) is 2, not 3. + my $y = int($x->[0] ** (1 / $n->[0])); + my $yp1 = $y + 1; + $y = $yp1 if $yp1 ** $n->[0] == $x->[0]; + $x->[0] = $y; + return $x; + } } # If x <= n, the result is always (truncated to) 1. @@ -1891,7 +1816,7 @@ sub _root { if ((@$x > 1 || $x -> [0] > 0) && # if x is non-zero ... $c -> _acmp($x, $n) <= 0) # ... and x <= n { - my $one = $x -> _one(); + my $one = $c -> _one(); @$x = @$one; return $x; } @@ -2173,7 +2098,6 @@ sub _or { # $b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; } # $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; } # $c->_add($x, $c->_mul(_new( $c, ($xrr | $yrr) ), $m) ); - $c->_add($z, $c->_mul([ 0 + $xr->[0] | 0 + $yr->[0] ], $m)); $c->_mul($m, $mask); } @@ -2191,94 +2115,70 @@ sub _as_hex { # convert a decimal number to hex (ref to array, return ref to string) my ($c, $x) = @_; - # fits into one element (handle also 0x0 case) - return sprintf("0x%x", $x->[0]) if @$x == 1; + return "0x0" if @$x == 1 && $x->[0] == 0; my $x1 = $c->_copy($x); + my $x10000 = [ 0x10000 ]; + my $es = ''; - my ($xr, $h, $x10000); - if ($] >= 5.006) { - $x10000 = [ 0x10000 ]; - $h = 'h4'; - } else { - $x10000 = [ 0x1000 ]; - $h = 'h3'; - } - while (@$x1 != 1 || $x1->[0] != 0) # _is_zero() - { + my $xr; + until (@$x1 == 1 && $x1->[0] == 0) { # _is_zero() ($x1, $xr) = $c->_div($x1, $x10000); - $es .= unpack($h, pack('V', $xr->[0])); + $es = sprintf('%04x', $xr->[0]) . $es; } - $es = reverse $es; - $es =~ s/^[0]+//; # strip leading zeros - '0x' . $es; # return result prepended with 0x + #$es = reverse $es; + $es =~ s/^0*/0x/; + return $es; } sub _as_bin { # convert a decimal number to bin (ref to array, return ref to string) my ($c, $x) = @_; - # fits into one element (and Perl recent enough), handle also 0b0 case - # handle zero case for older Perls - if ($] <= 5.005 && @$x == 1 && $x->[0] == 0) { - my $t = '0b0'; - return $t; - } - if (@$x == 1 && $] >= 5.006) { - my $t = sprintf("0b%b", $x->[0]); - return $t; - } + return "0b0" if @$x == 1 && $x->[0] == 0; + my $x1 = $c->_copy($x); + my $x10000 = [ 0x10000 ]; + my $es = ''; - my ($xr, $b, $x10000); - if ($] >= 5.006) { - $x10000 = [ 0x10000 ]; - $b = 'b16'; - } else { - $x10000 = [ 0x1000 ]; - $b = 'b12'; - } - while (!(@$x1 == 1 && $x1->[0] == 0)) # _is_zero() - { + my $xr; + + until (@$x1 == 1 && $x1->[0] == 0) { # _is_zero() ($x1, $xr) = $c->_div($x1, $x10000); - $es .= unpack($b, pack('v', $xr->[0])); + $es = sprintf('%016b', $xr->[0]) . $es; } - $es = reverse $es; - $es =~ s/^[0]+//; # strip leading zeros - '0b' . $es; # return result prepended with 0b + $es =~ s/^0*/0b/; + return $es; } sub _as_oct { # convert a decimal number to octal (ref to array, return ref to string) my ($c, $x) = @_; - # fits into one element (handle also 0 case) - return sprintf("0%o", $x->[0]) if @$x == 1; + return "00" if @$x == 1 && $x->[0] == 0; my $x1 = $c->_copy($x); + my $x1000 = [ 1 << 15 ]; # 15 bits = 32768 = 0100000 + my $es = ''; my $xr; - my $x1000 = [ 0100000 ]; - while (@$x1 != 1 || $x1->[0] != 0) # _is_zero() - { + until (@$x1 == 1 && $x1->[0] == 0) { # _is_zero() ($x1, $xr) = $c->_div($x1, $x1000); - $es .= reverse sprintf("%05o", $xr->[0]); + $es = sprintf("%05o", $xr->[0]) . $es; } - $es = reverse $es; - $es =~ s/^0+//; # strip leading zeros - '0' . $es; # return result prepended with 0 + $es =~ s/^0*/0/; # excactly one leading zero + return $es; } sub _from_oct { # convert a octal number to decimal (string, return ref to array) my ($c, $os) = @_; - # for older Perls, play safe - my $m = [ 0100000 ]; - my $d = 5; # 5 digits at a time + my $m = $c->_new(1 << 30); # 30 bits at a time (<32 bits!) + my $d = 10; # 10 octal digits at a time my $mul = $c->_one(); my $x = $c->_zero(); @@ -2291,7 +2191,7 @@ sub _from_oct { $val = CORE::oct($val); $i -= $d; $len --; - my $adder = [ $val ]; + my $adder = $c -> _new($val); $c->_add($x, $c->_mul($adder, $mul)) if $val != 0; $c->_mul($mul, $m) if $len >= 0; # skip last mul } @@ -2302,8 +2202,8 @@ sub _from_hex { # convert a hex number to decimal (string, return ref to array) my ($c, $hs) = @_; - my $m = $c->_new(0x10000000); # 28 bit at a time (<32 bit!) - my $d = 7; # 7 digits at a time + my $m = $c->_new(0x10000000); # 28 bit at a time (<32 bit!) + my $d = 7; # 7 hexadecimal digits at a time my $mul = $c->_one(); my $x = $c->_zero(); @@ -2316,7 +2216,7 @@ sub _from_hex { $val = CORE::hex($val); # hex does not like wrong chars $i -= $d; $len --; - my $adder = [ $val ]; + my $adder = $c->_new($val); # if the resulting number was to big to fit into one element, create a # two-element version (bug found by Mark Lakata - Thanx!) if (CORE::length($val) > $BASE_LEN) { @@ -2348,12 +2248,13 @@ sub _from_bin { # special modulus functions sub _modinv { + # modular multiplicative inverse my ($c, $x, $y) = @_; # modulo zero if ($c->_is_zero($y)) { - return undef, undef; + return; } # modulo one @@ -2384,7 +2285,7 @@ sub _modinv { } # if the gcd is not 1, then return NaN - return (undef, undef) unless $c->_is_one($a); + return unless $c->_is_one($a); ($v, $sign == 1 ? '+' : '-'); } @@ -2471,7 +2372,7 @@ sub _gcd { =head1 NAME -Math::BigInt::Calc - Pure Perl module to support Math::BigInt +Math::BigInt::Calc - pure Perl module to support Math::BigInt =head1 SYNOPSIS @@ -2484,25 +2385,76 @@ Math::BigInt::Calc - Pure Perl module to support Math::BigInt # to use it with Math::BigRat use Math::BigRat lib => 'Calc'; + # explicitly set base length and whether to "use integer" + use Math::BigInt::Calc base_len => 4, use_int => 1; + use Math::BigInt lib => 'Calc'; + =head1 DESCRIPTION Math::BigInt::Calc inherits from Math::BigInt::Lib. -In this library, the numbers are represented in base B = 10**N, where N is the -largest possible value that does not cause overflow in the intermediate -computations. The base B elements are stored in an array, with the least -significant element stored in array element zero. There are no leading zero -elements, except a single zero element when the number is zero. +In this library, the numbers are represented interenally in base B = 10**N, +where N is the largest possible integer that does not cause overflow in the +intermediate computations. The base B elements are stored in an array, with the +least significant element stored in array element zero. There are no leading +zero elements, except a single zero element when the number is zero. For +instance, if B = 10000, the number 1234567890 is represented internally as +[7890, 3456, 12]. + +=head1 OPTIONS + +When the module is loaded, it computes the maximum exponent, i.e., power of 10, +that can be used with and without "use integer" in the computations. The default +is to use this maximum exponent. If the combination of the 'base_len' value and +the 'use_int' value exceeds the maximum value, an error is thrown. + +=over 4 + +=item base_len + +The base length can be specified explicitly with the 'base_len' option. The +value must be a positive integer. + + use Math::BigInt::Calc base_len => 4; # use 10000 as internal base + +=item use_int + +This option is used to specify whether "use integer" should be used in the +internal computations. The value is interpreted as a boolean value, so use 0 or +"" for false and anything else for true. If the 'base_len' is not specified +together with 'use_int', the current value for the base length is used. + + use Math::BigInt::Calc use_int => 1; # use "use integer" internally + +=back + +=head1 METHODS + +This overview constains only the methods that are specific to +C<Math::BigInt::Calc>. For the other methods, see L<Math::BigInt::Lib>. + +=over 4 + +=item _base_len() + +Specify the desired base length and whether to enable "use integer" in the +computations. + + Math::BigInt::Calc -> _base_len($base_len, $use_int); + +Note that it is better to specify the base length and whether to use integers as +options when the module is loaded, for example like this + + use Math::BigInt::Calc base_len => 6, use_int => 1; -For instance, if B = 10000, the number 1234567890 is represented internally -as [7890, 3456, 12]. +=back =head1 SEE ALSO L<Math::BigInt::Lib> for a description of the API. -Alternative libraries L<Math::BigInt::FastCalc>, L<Math::BigInt::GMP>, and -L<Math::BigInt::Pari>. +Alternative libraries L<Math::BigInt::FastCalc>, L<Math::BigInt::GMP>, +L<Math::BigInt::Pari>, L<Math::BigInt::GMPz>, and L<Math::BigInt::BitVect>. Some of the modules that use these libraries L<Math::BigInt>, L<Math::BigFloat>, and L<Math::BigRat>. 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 4e903bd4f1..ee2c29de3b 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/FastCalc.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/FastCalc.pm @@ -1,28 +1,89 @@ package Math::BigInt::FastCalc; -use 5.006; +use 5.006001; use strict; use warnings; +use Carp qw< carp croak >; + use Math::BigInt::Calc 1.999801; -our @ISA = qw< Math::BigInt::Calc >; +BEGIN { + our @ISA = qw< Math::BigInt::Calc >; +} + +our $VERSION = '0.5013'; + +my $MAX_EXP_F; # the maximum possible base 10 exponent with "no integer" +my $MAX_EXP_I; # the maximum possible base 10 exponent with "use integer" +my $BASE_LEN; # the current base exponent in use +my $USE_INT; # whether "use integer" is used in the computations + +sub _base_len { + my $class = shift; + + if (@_) { # if called as setter ... + my ($base_len, $use_int) = @_; + + croak "The base length must be a positive integer" + unless defined($base_len) && $base_len == int($base_len) + && $base_len > 0; + + if ( $use_int && ($base_len > $MAX_EXP_I) || + !$use_int && ($base_len > $MAX_EXP_F)) + { + croak "The maximum base length (exponent) is $MAX_EXP_I with", + " 'use integer' and $MAX_EXP_F without 'use integer'. The", + " requested settings, a base length of $base_len ", + $use_int ? "with" : "without", " 'use integer', is invalid."; + } + + return $class -> SUPER::_base_len($base_len, $use_int); + } + + return $class -> SUPER::_base_len(); +} -our $VERSION = '0.5009'; +BEGIN { + + my @params = Math::BigInt::FastCalc -> SUPER::_base_len(); + $BASE_LEN = $params[0]; + $MAX_EXP_F = $params[8]; + $MAX_EXP_I = $params[9]; + + # With quadmath support it should work with a base length of 17, because the + # maximum intermediate value used in the computations is less than 2**113. + # However, for some reason a base length of 17 doesn't work, but trial and + # error shows that a base length of 15 works for all methods except + # _is_odd() and _is_even(). These two methods determine whether the least + # significand component is odd or even by converting it to a UV and do a + # bitwise & operation. Because of this, we need to limit the base length to + # what fits inside an UV. + + require Config; + my $max_exp_i = int(8 * $Config::Config{uvsize} * log(2) / log(10)); + $MAX_EXP_I = $max_exp_i if $max_exp_i < $MAX_EXP_I; + $MAX_EXP_F = $MAX_EXP_I if $MAX_EXP_I < $MAX_EXP_F; + + ($BASE_LEN, $USE_INT) = $MAX_EXP_I > $MAX_EXP_F ? ($MAX_EXP_I, 1) + : ($MAX_EXP_F, 0); + + Math::BigInt::FastCalc -> SUPER::_base_len($BASE_LEN, $USE_INT); +} ############################################################################## # global constants, flags and accessory -# announce that we are compatible with MBI v1.83 and up -sub api_version () { 2; } +# Announce that we are compatible with MBI v1.83 and up. This method has been +# made redundant. Each backend is now a subclass of Math::BigInt::Lib, which +# provides the methods not present in the subclasses. -# use Calc to override the methods that we do not provide in XS +sub api_version () { 2; } require XSLoader; XSLoader::load(__PACKAGE__, $VERSION, Math::BigInt::Calc->_base_len()); ############################################################################## -############################################################################## 1; @@ -57,12 +118,20 @@ In order to allow for multiple big integer libraries, Math::BigInt was rewritten to use library modules for core math routines. Any module which follows the same API as this can be used instead by using the following: - use Math::BigInt lib => 'libname'; + use Math::BigInt lib => 'libname'; 'libname' is either the long name ('Math::BigInt::Pari'), or only the short version like 'Pari'. To use this library: - use Math::BigInt lib => 'FastCalc'; + use Math::BigInt lib => 'FastCalc'; + +The default behaviour is to chose the best internal representation of big +integers, but the base length used in the internal representation can be +specified explicitly. Note that this must be done before Math::BigInt is loaded. +For example, + + use Math::BigInt::FastCalc base_len => 3; + use Math::BigInt lib => 'FastCalc'; =head1 STORAGE @@ -73,25 +142,25 @@ stored in decimal form chopped into parts. The following functions are now implemented in FastCalc.xs: - _is_odd _is_even _is_one _is_zero - _is_two _is_ten - _zero _one _two _ten - _acmp _len - _inc _dec - __strip_zeros _copy + _is_odd _is_even _is_one _is_zero + _is_two _is_ten + _zero _one _two _ten + _acmp _len + _inc _dec + __strip_zeros _copy =head1 BUGS Please report any bugs or feature requests to C<bug-math-bigint-fastcalc at rt.cpan.org>, or through the web interface at L<https://rt.cpan.org/Ticket/Create.html?Queue=Math-BigInt-FastCalc> -(requires login). -We will be notified, and then you'll automatically be notified of progress on -your bug as I make changes. +(requires login). We will be notified, and then you'll automatically be +notified of progress on your bug as I make changes. =head1 SUPPORT -You can find documentation for this module with the perldoc command. +After installing, you can find documentation for this module with the perldoc +command. perldoc Math::BigInt::FastCalc @@ -99,43 +168,25 @@ You can also look for information at: =over 4 -=item * RT: CPAN's request tracker +=item GitHub -L<https://rt.cpan.org/Public/Dist/Display.html?Name=Math-BigInt-FastCalc> +L<https://github.com/pjacklam/p5-Math-BigInt-FastCalc> -=item * AnnoCPAN: Annotated CPAN documentation +=item RT: CPAN's request tracker -L<http://annocpan.org/dist/Math-BigInt-FastCalc> +L<https://rt.cpan.org/Dist/Display.html?Name=Math-BigInt-FastCalc> -=item * CPAN Ratings +=item MetaCPAN -L<http://cpanratings.perl.org/dist/Math-BigInt-FastCalc> +L<https://metacpan.org/release/Math-BigInt-FastCalc> -=item * Search CPAN - -L<http://search.cpan.org/dist/Math-BigInt-FastCalc/> - -=item * CPAN Testers Matrix +=item CPAN Testers Matrix L<http://matrix.cpantesters.org/?dist=Math-BigInt-FastCalc> -=item * The Bignum mailing list - -=over 4 - -=item * Post to mailing list - -C<bignum at lists.scsys.co.uk> - -=item * View mailing list - -L<http://lists.scsys.co.uk/pipermail/bignum/> +=item CPAN Ratings -=item * Subscribe/Unsubscribe - -L<http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/bignum> - -=back +L<https://cpanratings.perl.org/dist/Math-BigInt-FastCalc> =back @@ -148,12 +199,13 @@ the same terms as Perl itself. Original math code by Mark Biggar, rewritten by Tels L<http://bloodgate.com/> in late 2000. -Separated from BigInt and shaped API with the help of John Peacock. + +Separated from Math::BigInt and shaped API with the help of John Peacock. Fixed, sped-up and enhanced by Tels http://bloodgate.com 2001-2003. Further streamlining (api_version 1 etc.) by Tels 2004-2007. -Bug-fixing by Peter John Acklam E<lt>pjacklam@online.noE<gt> 2010-2016. +Maintained by Peter John Acklam E<lt>pjacklam@gmail.comE<gt> 2010-2021. =head1 SEE ALSO 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 fde281297f..37fa9b94de 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,8 @@ use 5.006001; use strict; use warnings; -our $VERSION = '1.999818'; +our $VERSION = '1.999837'; +$VERSION =~ tr/_//d; use Carp; @@ -88,7 +89,7 @@ use overload $x = $_[0]; $y = ref($_[1]) ? $class -> _num($_[1]) : $_[1]; } - return $class -> _blsft($x, $y); + return $class -> _lsft($x, $y); }, '>>' => sub { @@ -101,7 +102,7 @@ use overload $x = $class -> _copy($_[0]); $y = ref($_[1]) ? $_[1] : $class -> _new($_[1]); } - return $class -> _brsft($x, $y); + return $class -> _rsft($x, $y); }, # overload key: num_comparison @@ -352,6 +353,56 @@ sub _dec { $class -> _sub($x, $class -> _one()); } +# Signed addition. If the flag is false, $xa might be modified, but not $ya. If +# the false is true, $ya might be modified, but not $xa. + +sub _sadd { + my $class = shift; + my ($xa, $xs, $ya, $ys, $flag) = @_; + my ($za, $zs); + + # If the signs are equal we can add them (-5 + -3 => -(5 + 3) => -8) + + if ($xs eq $ys) { + if ($flag) { + $za = $class -> _add($ya, $xa); + } else { + $za = $class -> _add($xa, $ya); + } + $zs = $class -> _is_zero($za) ? '+' : $xs; + return $za, $zs; + } + + my $acmp = $class -> _acmp($xa, $ya); # abs(x) = abs(y) + + if ($acmp == 0) { # x = -y or -x = y + $za = $class -> _zero(); + $zs = '+'; + return $za, $zs; + } + + if ($acmp > 0) { # abs(x) > abs(y) + $za = $class -> _sub($xa, $ya, $flag); + $zs = $xs; + } else { # abs(x) < abs(y) + $za = $class -> _sub($ya, $xa, !$flag); + $zs = $ys; + } + return $za, $zs; +} + +# Signed subtraction. If the flag is false, $xa might be modified, but not $ya. +# If the false is true, $ya might be modified, but not $xa. + +sub _ssub { + my $class = shift; + my ($xa, $xs, $ya, $ys, $flag) = @_; + + # Swap sign of second operand and let _sadd() do the job. + $ys = $ys eq '+' ? '-' : '+'; + $class -> _sadd($xa, $xs, $ya, $ys, $flag); +} + ############################################################################## # testing @@ -573,23 +624,54 @@ sub _nok { return $n; } +#sub _fac { +# # factorial +# my ($class, $x) = @_; +# +# my $two = $class -> _two(); +# +# if ($class -> _acmp($x, $two) < 0) { +# return $class -> _one(); +# } +# +# my $i = $class -> _copy($x); +# while ($class -> _acmp($i, $two) > 0) { +# $i = $class -> _dec($i); +# $x = $class -> _mul($x, $i); +# } +# +# return $x; +#} + sub _fac { # factorial my ($class, $x) = @_; - my $two = $class -> _two(); + # This is an implementation of the split recursive algorithm. See + # http://www.luschny.de/math/factorial/csharp/FactorialSplit.cs.html - if ($class -> _acmp($x, $two) < 0) { - return $class -> _one(); - } + my $p = $class -> _one(); + my $r = $class -> _one(); + my $two = $class -> _two(); - my $i = $class -> _copy($x); - while ($class -> _acmp($i, $two) > 0) { - $i = $class -> _dec($i); - $x = $class -> _mul($x, $i); + my ($log2n) = $class -> _log_int($class -> _copy($x), $two); + my $h = $class -> _zero(); + my $shift = $class -> _zero(); + my $k = $class -> _one(); + + while ($class -> _acmp($h, $x)) { + $shift = $class -> _add($shift, $h); + $h = $class -> _rsft($class -> _copy($x), $log2n, $two); + $log2n = $class -> _dec($log2n) if !$class -> _is_zero($log2n); + my $high = $class -> _copy($h); + $high = $class -> _dec($high) if $class -> _is_even($h); + while ($class -> _acmp($k, $high)) { + $k = $class -> _add($k, $two); + $p = $class -> _mul($p, $k); + } + $r = $class -> _mul($r, $p); } - - return $x; + return $class -> _lsft($r, $shift, $two); } sub _dfac { @@ -725,7 +807,7 @@ sub _sqrt { # # x(i+1) = x(i) - f(x(i)) / f'(x(i)) # = x(i) - (x(i)^2 - y) / (2 * x(i)) # use if x(i)^2 > y - # = y(i) + (y - x(i)^2) / (2 * x(i)) # use if x(i)^2 < y + # = x(i) + (y - x(i)^2) / (2 * x(i)) # use if x(i)^2 < y # Determine if x, our guess, is too small, correct, or too large. @@ -1433,7 +1515,9 @@ sub _to_base { my $collseq; if (@_) { - $collseq = shift(); + $collseq = shift; + croak "The collation sequence must be a non-empty string" + unless defined($collseq) && length($collseq); } else { if ($class -> _acmp($base, $class -> _new("94")) <= 0) { $collseq = '0123456789' # 48 .. 57 @@ -1461,10 +1545,40 @@ sub _to_base { my $chr = $collseq[$num]; $str = $chr . $str; } - return "0" unless length $str; + return $collseq[0] unless length $str; return $str; } +sub _to_base_num { + # Convert the number to an array of integers in any base. + my ($class, $x, $base) = @_; + + # Make sure the base is an object and >= 2. + $base = $class -> _new($base) unless ref($base); + my $two = $class -> _two(); + croak "base must be >= 2" unless $class -> _acmp($base, $two) >= 0; + + my $out = []; + my $xcopy = $class -> _copy($x); + my $rem; + + # Do all except the last (most significant) element. + until ($class -> _acmp($xcopy, $base) < 0) { + ($xcopy, $rem) = $class -> _div($xcopy, $base); + unshift @$out, $rem; + } + + # Do the last (most significant element). + unless ($class -> _is_zero($xcopy)) { + unshift @$out, $xcopy; + } + + # $out is empty if $x is zero. + unshift @$out, $class -> _zero() unless @$out; + + return $out; +} + sub _from_hex { # Convert a string of hexadecimal digits to a number. @@ -1622,6 +1736,32 @@ sub _from_base { return $x; } +sub _from_base_num { + # Convert an array in the given base to a number. + my ($class, $in, $base) = @_; + + # Make sure the base is an object and >= 2. + $base = $class -> _new($base) unless ref($base); + my $two = $class -> _two(); + croak "base must be >= 2" unless $class -> _acmp($base, $two) >= 0; + + # @$in = map { ref($_) ? $_ : $class -> _new($_) } @$in; + + my $ele = $in -> [0]; + + $ele = $class -> _new($ele) unless ref($ele); + my $x = $class -> _copy($ele); + + for my $i (1 .. $#$in) { + $x = $class -> _mul($x, $base); + $ele = $in -> [$i]; + $ele = $class -> _new($ele) unless ref($ele); + $x = $class -> _add($x, $ele); + } + + return $x; +} + ############################################################################## # special modulus functions @@ -1631,7 +1771,7 @@ sub _modinv { # modulo zero if ($class -> _is_zero($y)) { - return (undef, undef); + return; } # modulo one @@ -1661,7 +1801,7 @@ sub _modinv { } # if the gcd is not 1, there exists no modular multiplicative inverse - return (undef, undef) unless $class -> _is_one($a); + return unless $class -> _is_one($a); ($v, $sign == 1 ? '+' : '-'); } @@ -1786,8 +1926,6 @@ sub _lucas { return @y; } - require Scalar::Util; - # In scalar context use that lucas(n) = fib(n-1) + fib(n+1). # # Remember that _fib() behaves differently in scalar context and list @@ -1795,8 +1933,8 @@ sub _lucas { return $class -> _two() if $n == 0; - return $class -> _add(scalar $class -> _fib($n - 1), - scalar $class -> _fib($n + 1)); + return $class -> _add(scalar($class -> _fib($n - 1)), + scalar($class -> _fib($n + 1))); } sub _fib { @@ -1876,8 +2014,8 @@ Math::BigInt::Lib - virtual parent class for Math::BigInt libraries package Math::BigInt::MyBackend; - use Math::BigInt::lib; - our @ISA = qw< Math::BigInt::lib >; + use Math::BigInt::Lib; + our @ISA = qw< Math::BigInt::Lib >; sub _new { ... } sub _str { ... } @@ -2035,6 +2173,16 @@ Some more examples, all returning 250: $x = $class -> _from_base("42", 62) $x = $class -> _from_base("2!", 94) +=item CLASS-E<gt>_from_base_num(ARRAY, BASE) + +Returns an object given an array of values and a base. This method is +equivalent to C<_from_base()>, but works on numbers in an array rather than +characters in a string. Unlike C<_from_base()>, all input values may be +arbitrarily large. + + $x = $class -> _from_base_num([1, 1, 0, 1], 2) # $x is 13 + $x = $class -> _from_base_num([3, 125, 39], 128) # $x is 65191 + =back =head3 Mathematical functions @@ -2043,24 +2191,38 @@ Some more examples, all returning 250: =item CLASS-E<gt>_add(OBJ1, OBJ2) -Returns the result of adding OBJ2 to OBJ1. +Addition. Returns the result of adding OBJ2 to OBJ1. =item CLASS-E<gt>_mul(OBJ1, OBJ2) -Returns the result of multiplying OBJ2 and OBJ1. +Multiplication. Returns the result of multiplying OBJ2 and OBJ1. =item CLASS-E<gt>_div(OBJ1, OBJ2) -In scalar context, returns the quotient after dividing OBJ1 by OBJ2 and -truncating the result to an integer. In list context, return the quotient and -the remainder. +Division. In scalar context, returns the quotient after dividing OBJ1 by OBJ2 +and truncating the result to an integer. In list context, return the quotient +and the remainder. =item CLASS-E<gt>_sub(OBJ1, OBJ2, FLAG) =item CLASS-E<gt>_sub(OBJ1, OBJ2) -Returns the result of subtracting OBJ2 by OBJ1. If C<flag> is false or omitted, -OBJ1 might be modified. If C<flag> is true, OBJ2 might be modified. +Subtraction. Returns the result of subtracting OBJ2 by OBJ1. If C<flag> is false +or omitted, OBJ1 might be modified. If C<flag> is true, OBJ2 might be modified. + +=item CLASS-E<gt>_sadd(OBJ1, SIGN1, OBJ2, SIGN2) + +Signed addition. Returns the result of adding OBJ2 with sign SIGN2 to OBJ1 with +sign SIGN1. + + ($obj3, $sign3) = $class -> _sadd($obj1, $sign1, $obj2, $sign2); + +=item CLASS-E<gt>_ssub(OBJ1, SIGN1, OBJ2, SIGN2) + +Signed subtraction. Returns the result of subtracting OBJ2 with sign SIGN2 to +OBJ1 with sign SIGN1. + + ($obj3, $sign3) = $class -> _sadd($obj1, $sign1, $obj2, $sign2); =item CLASS-E<gt>_dec(OBJ) @@ -2268,6 +2430,16 @@ COLLSEQ. See _from_base() for more information. +=item CLASS-E<gt>_to_base_num(OBJ, BASE) + +Converts the given number to the given base. This method is equivalent to +C<_to_base()>, but returns numbers in an array rather than characters in a +string. In the output, the first element is the most significant. Unlike +C<_to_base()>, all input values may be arbitrarily large. + + $x = $class -> _to_base_num(13, 2) # $x is [1, 1, 0, 1] + $x = $class -> _to_base_num(65191, 128) # $x is [3, 125, 39] + =item CLASS-E<gt>_as_bin(OBJ) Like C<_to_bin()> but with a '0b' prefix. @@ -2460,7 +2632,7 @@ the same terms as Perl itself. =head1 AUTHOR -Peter John Acklam, E<lt>pjacklam@online.noE<gt> +Peter John Acklam, E<lt>pjacklam@gmail.comE<gt> Code and documentation based on the Math::BigInt::Calc module by Tels E<lt>nospam-abuse@bloodgate.comE<gt> diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Trace.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Trace.pm index 5517bedad9..16ac187abb 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Trace.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Trace.pm @@ -1,48 +1,76 @@ -#!perl +# -*- mode: perl; -*- package Math::BigInt::Trace; -require 5.010; use strict; use warnings; use Exporter; use Math::BigInt; -our ($accuracy, $precision, $round_mode, $div_scale); - our @ISA = qw(Exporter Math::BigInt); -our $VERSION = '0.51'; +our $VERSION = '0.66'; use overload; # inherit overload from Math::BigInt # Globals -$accuracy = $precision = undef; -$round_mode = 'even'; -$div_scale = 40; +our $accuracy = undef; +our $precision = undef; +our $round_mode = 'even'; +our $div_scale = 40; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $value = shift; + my $a = $accuracy; $a = $_[0] if defined $_[0]; + my $p = $precision; $p = $_[1] if defined $_[1]; - my $self = Math::BigInt->new($value, $a, $p, $round_mode); - bless $self, $class; - print "MBI new '$value' => '$self' (", ref($self), ")"; + + my $self = $class -> SUPER::new($value, $a, $p, $round_mode); + + printf "Math::BigInt new '%s' => '%s' (%s)\n", + $value, $self, ref($self); + return $self; } sub import { - print "MBI import ", join(' ', @_); - my $self = shift; - Math::BigInt::import($self, @_); # need it for subclasses -# $self->export_to_level(1, $self, @_); # need this ? - @_ = (); + my $class = shift; + + printf "%s -> import(%s)\n", $class, join(", ", @_); + + # we catch the constants, the rest goes to parent + + my $constant = grep { $_ eq ':constant' } @_; + my @a = grep { $_ ne ':constant' } @_; + + if ($constant) { + overload::constant + + integer => sub { + $class -> new(shift); + }, + + float => sub { + $class -> new(shift); + }, + + binary => sub { + # E.g., a literal 0377 shall result in an object whose value + # is decimal 255, but new("0377") returns decimal 377. + return $class -> from_oct($_[0]) if $_[0] =~ /^0_*[0-7]/; + $class -> new(shift); + }; + } + + $class -> SUPER::import(@a); # need it for subclasses + #$self -> export_to_level(1, $class, @_); # need this ? } 1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigRat.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigRat.pm index e3d172836c..0d0f246795 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigRat.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigRat.pm @@ -16,11 +16,12 @@ use 5.006; use strict; use warnings; -use Carp qw< carp croak >; +use Carp qw< carp croak >; +use Scalar::Util qw< blessed >; -use Math::BigFloat 1.999718; +use Math::BigFloat (); -our $VERSION = '0.2614'; +our $VERSION = '0.2624'; our @ISA = qw(Math::BigFloat); @@ -199,12 +200,6 @@ use overload BEGIN { *objectify = \&Math::BigInt::objectify; # inherit this from BigInt *AUTOLOAD = \&Math::BigFloat::AUTOLOAD; # can't inherit AUTOLOAD - # We inherit these from BigFloat because currently it is not possible that - # Math::BigFloat has a different $LIB variable than we, because - # Math::BigFloat also uses Math::BigInt::config->('lib') (there is always - # only one library loaded) - *_e_add = \&Math::BigFloat::_e_add; - *_e_sub = \&Math::BigFloat::_e_sub; *as_number = \&as_int; *is_pos = \&is_positive; *is_neg = \&is_negative; @@ -305,20 +300,32 @@ sub new { unless (defined $d) { #return $n -> copy($n) if $n -> isa('Math::BigRat'); - return $class -> copy($n) if $n -> isa('Math::BigRat'); - return $class -> bnan() if $n -> is_nan(); - return $class -> binf($n -> sign()) if $n -> is_inf(); + if ($n -> isa('Math::BigRat')) { + return $downgrade -> new($n) + if defined($downgrade) && $n -> is_int(); + return $class -> copy($n); + } + + if ($n -> is_nan()) { + return $class -> bnan(); + } + + if ($n -> is_inf()) { + return $class -> binf($n -> sign()); + } if ($n -> isa('Math::BigInt')) { - $self -> {_n} = $LIB -> _new($n -> copy() -> babs() -> bstr()); + $self -> {_n} = $LIB -> _new($n -> copy() -> babs(undef, undef) + -> bstr()); $self -> {_d} = $LIB -> _one(); $self -> {sign} = $n -> sign(); + return $downgrade -> new($n) if defined $downgrade; return $self; } if ($n -> isa('Math::BigFloat')) { - my $m = $n -> mantissa() -> babs(); - my $e = $n -> exponent(); + my $m = $n -> mantissa(undef, undef) -> babs(undef, undef); + my $e = $n -> exponent(undef, undef); $self -> {_n} = $LIB -> _new($m -> bstr()); $self -> {_d} = $LIB -> _one(); @@ -329,7 +336,8 @@ sub new { $self -> {_d} = $LIB -> _lsft($self -> {_d}, $LIB -> _new(-$e -> bstr()), 10); - my $gcd = $LIB -> _gcd($LIB -> _copy($self -> {_n}), $self -> {_d}); + my $gcd = $LIB -> _gcd($LIB -> _copy($self -> {_n}), + $self -> {_d}); if (!$LIB -> _is_one($gcd)) { $self -> {_n} = $LIB -> _div($self->{_n}, $gcd); $self -> {_d} = $LIB -> _div($self->{_d}, $gcd); @@ -337,6 +345,8 @@ sub new { } $self -> {sign} = $n -> sign(); + return $downgrade -> new($n, undef, undef) + if defined($downgrade) && $n -> is_int(); return $self; } @@ -353,19 +363,30 @@ sub new { # At this point both $n and $d are objects. - return $class -> bnan() if $n -> is_nan() || $d -> is_nan(); + if ($n -> is_nan() || $d -> is_nan()) { + return $class -> bnan(); + } # At this point neither $n nor $d is a NaN. if ($n -> is_zero()) { - return $class -> bnan() if $d -> is_zero(); # 0/0 = NaN + if ($d -> is_zero()) { # 0/0 = NaN + return $class -> bnan(); + } return $class -> bzero(); } - return $class -> binf($d -> sign()) if $d -> is_zero(); + if ($d -> is_zero()) { + return $class -> binf($d -> sign()); + } # At this point, neither $n nor $d is a NaN or a zero. + # Copy them now before manipulating them. + + $n = $n -> copy(); + $d = $d -> copy(); + if ($d < 0) { # make sure denominator is positive $n -> bneg(); $d -> bneg(); @@ -411,6 +432,8 @@ sub new { $self -> {_d} = $LIB -> _mul($LIB -> _div($LIB -> _copy($q), $gcd_sq), $LIB -> _div($LIB -> _copy($r), $gcd_pr)); + return $downgrade -> new($n->bstr()) + if defined($downgrade) && $self -> is_int(); return $self; # no need for $self -> bnorm() here } @@ -516,6 +539,8 @@ sub new { } } + return $downgrade -> new($self -> bstr()) + if defined($downgrade) && $self -> is_int(); return $self; } @@ -553,6 +578,8 @@ sub bnan { croak ("Tried to set a variable to NaN in $class->bnan()"); } + return $downgrade -> bnan() if defined $downgrade; + $self -> {sign} = $nan; $self -> {_n} = $LIB -> _zero(); $self -> {_d} = $LIB -> _one(); @@ -577,6 +604,8 @@ sub binf { croak ("Tried to set a variable to +-inf in $class->binf()"); } + return $downgrade -> binf($sign) if defined $downgrade; + $self -> {sign} = $sign; $self -> {_n} = $LIB -> _zero(); $self -> {_d} = $LIB -> _one(); @@ -592,11 +621,12 @@ sub bone { my $selfref = ref $self; my $class = $selfref || $self; - $self = bless {}, $class unless $selfref; - my $sign = shift(); $sign = '+' unless defined($sign) && $sign eq '-'; + return $downgrade -> bone($sign) if defined $downgrade; + + $self = bless {}, $class unless $selfref; $self -> {sign} = $sign; $self -> {_n} = $LIB -> _one(); $self -> {_d} = $LIB -> _one(); @@ -612,8 +642,9 @@ sub bzero { my $selfref = ref $self; my $class = $selfref || $self; - $self = bless {}, $class unless $selfref; + return $downgrade -> bzero() if defined $downgrade; + $self = bless {}, $class unless $selfref; $self -> {sign} = '+'; $self -> {_n} = $LIB -> _zero(); $self -> {_d} = $LIB -> _one(); @@ -644,36 +675,86 @@ sub config { $cfg; } -############################################################################## +############################################################################### +# String conversion methods +############################################################################### sub bstr { - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN - if ($x->{sign} !~ /^[+-]$/) { # inf, NaN etc - my $s = $x->{sign}; - $s =~ s/^\+//; # +inf => inf - return $s; + if ($x->{sign} ne '+' && $x->{sign} ne '-') { + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf } + # Upgrade? + + return $upgrade -> bstr($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number + my $s = ''; $s = $x->{sign} if $x->{sign} ne '+'; # '+3/2' => '3/2' - return $s . $LIB->_str($x->{_n}) if $LIB->_is_one($x->{_d}); - $s . $LIB->_str($x->{_n}) . '/' . $LIB->_str($x->{_d}); + my $str = $x->{sign} eq '-' ? '-' : ''; + $str .= $LIB->_str($x->{_n}); + $str .= '/' . $LIB->_str($x->{_d}) unless $LIB -> _is_one($x->{_d}); + return $str; } sub bsstr { - my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; - if ($x->{sign} !~ /^[+-]$/) { # inf, NaN etc - my $s = $x->{sign}; - $s =~ s/^\+//; # +inf => inf - return $s; + # Inf and NaN + + if ($x->{sign} ne '+' && $x->{sign} ne '-') { + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf } - my $s = ''; - $s = $x->{sign} if $x->{sign} ne '+'; # +3 vs 3 - $s . $LIB->_str($x->{_n}) . '/' . $LIB->_str($x->{_d}); + # Upgrade? + + return $upgrade -> bsstr($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number + + my $str = $x->{sign} eq '-' ? '-' : ''; + $str .= $LIB->_str($x->{_n}); + $str .= '/' . $LIB->_str($x->{_d}) unless $LIB -> _is_one($x->{_d}); + return $str; +} + +sub bfstr { + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + + carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; + + # Inf and NaN + + if ($x->{sign} ne '+' && $x->{sign} ne '-') { + return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN + return 'inf'; # +inf + } + + # Upgrade? + + return $upgrade -> bfstr($x, @r) + if defined($upgrade) && !$x -> isa($class); + + # Finite number + + my $str = $x->{sign} eq '-' ? '-' : ''; + $str .= $LIB->_str($x->{_n}); + $str .= '/' . $LIB->_str($x->{_d}) unless $LIB -> _is_one($x->{_d}); + return $str; } sub bnorm { @@ -689,16 +770,24 @@ sub bnorm { } # no normalize for NaN, inf etc. - return $x if $x->{sign} !~ /^[+-]$/; + if ($x->{sign} !~ /^[+-]$/) { + return $downgrade -> new($x) if defined $downgrade; + return $x; + } # normalize zeros to 0/1 if ($LIB->_is_zero($x->{_n})) { + return $downgrade -> bzero() if defined($downgrade); $x->{sign} = '+'; # never leave a -0 $x->{_d} = $LIB->_one() unless $LIB->_is_one($x->{_d}); return $x; } - return $x if $LIB->_is_one($x->{_d}); # no need to reduce + # n/1 + if ($LIB->_is_one($x->{_d})) { + return $downgrade -> new($x) if defined($downgrade); + return $x; # no need to reduce + } # Compute the GCD. my $gcd = $LIB->_gcd($LIB->_copy($x->{_n}), $x->{_d}); @@ -723,56 +812,10 @@ sub bneg { # for +0 do not negate (to have always normalized +0). Does nothing for 'NaN' $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $LIB->_is_zero($x->{_n})); - $x; -} - -############################################################################## -# special values - -sub _bnan { - # used by parent class bnan() to initialize number to NaN - my $self = shift; - - if ($_trap_nan) { - my $class = ref($self); - # "$self" below will stringify the object, this blows up if $self is a - # partial object (happens under trap_nan), so fix it beforehand - $self->{_d} = $LIB->_zero() unless defined $self->{_d}; - $self->{_n} = $LIB->_zero() unless defined $self->{_n}; - croak ("Tried to set $self to NaN in $class\::_bnan()"); - } - $self->{_n} = $LIB->_zero(); - $self->{_d} = $LIB->_zero(); -} - -sub _binf { - # used by parent class bone() to initialize number to +inf/-inf - my $self = shift; - - if ($_trap_inf) { - my $class = ref($self); - # "$self" below will stringify the object, this blows up if $self is a - # partial object (happens under trap_nan), so fix it beforehand - $self->{_d} = $LIB->_zero() unless defined $self->{_d}; - $self->{_n} = $LIB->_zero() unless defined $self->{_n}; - croak ("Tried to set $self to inf in $class\::_binf()"); - } - $self->{_n} = $LIB->_zero(); - $self->{_d} = $LIB->_zero(); -} - -sub _bone { - # used by parent class bone() to initialize number to +1/-1 - my $self = shift; - $self->{_n} = $LIB->_one(); - $self->{_d} = $LIB->_one(); -} -sub _bzero { - # used by parent class bzero() to initialize number to 0 - my $self = shift; - $self->{_n} = $LIB->_zero(); - $self->{_d} = $LIB->_one(); + return $downgrade -> new($x) + if defined($downgrade) && $LIB -> _is_one($x->{_d}); + $x; } ############################################################################## @@ -788,12 +831,21 @@ sub badd { ($class, $x, $y, @r) = objectify(2, @_); } - # +inf + +inf => +inf, -inf + -inf => -inf - return $x->binf(substr($x->{sign}, 0, 1)) - if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/; - - # +inf + -inf or -inf + +inf => NaN - return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/); + unless ($x -> is_finite() && $y -> is_finite()) { + if ($x -> is_nan() || $y -> is_nan()) { + return $x -> bnan(@r); + } elsif ($x -> is_inf("+")) { + return $x -> bnan(@r) if $y -> is_inf("-"); + return $x -> binf("+", @r); + } elsif ($x -> is_inf("-")) { + return $x -> bnan(@r) if $y -> is_inf("+"); + return $x -> binf("-", @r); + } elsif ($y -> is_inf("+")) { + return $x -> binf("+", @r); + } elsif ($y -> is_inf("-")) { + return $x -> binf("-", @r); + } + } # 1 1 gcd(3, 4) = 1 1*3 + 1*4 7 # - + - = --------- = -- @@ -813,7 +865,7 @@ sub badd { my $m = $LIB->_mul($LIB->_copy($y->{_n}), $x->{_d}); # 5 * 3 + 7 * 4 - ($x->{_n}, $x->{sign}) = _e_add($x->{_n}, $m, $x->{sign}, $y->{sign}); + ($x->{_n}, $x->{sign}) = $LIB -> _sadd($x->{_n}, $x->{sign}, $m, $y->{sign}); # 4 * 3 $x->{_d} = $LIB->_mul($x->{_d}, $y->{_d}); @@ -834,12 +886,12 @@ sub bsub { # flip sign of $x, call badd(), then flip sign of result $x->{sign} =~ tr/+-/-+/ - unless $x->{sign} eq '+' && $LIB->_is_zero($x->{_n}); # not -0 - $x->badd($y, @r); # does norm and round + unless $x->{sign} eq '+' && $x -> is_zero(); # not -0 + $x = $x->badd($y, @r); # does norm and round $x->{sign} =~ tr/+-/-+/ - unless $x->{sign} eq '+' && $LIB->_is_zero($x->{_n}); # not -0 + unless $x->{sign} eq '+' && $x -> is_zero(); # not -0 - $x; + $x->bnorm(); } sub bmul { @@ -866,10 +918,13 @@ sub bmul { } # x == 0 # also: or y == 1 or y == -1 - return wantarray ? ($x, $class->bzero()) : $x if $x -> is_zero(); + if ($x -> is_zero()) { + $x = $downgrade -> bzero($x) if defined $downgrade; + return wantarray ? ($x, $class->bzero()) : $x; + } if ($y -> is_zero()) { - $x -> bzero(); + $x = defined($downgrade) ? $downgrade -> bzero($x) : $x -> bzero(); return wantarray ? ($x, $class->bzero()) : $x; } @@ -893,7 +948,7 @@ sub bmul { # compute new sign $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; - $x->round(@r); + $x->bnorm()->round(@r); } sub bdiv { @@ -916,7 +971,15 @@ sub bdiv { # method. if ($x -> is_nan() || $y -> is_nan()) { - return $wantarray ? ($x -> bnan(), $class -> bnan()) : $x -> bnan(); + if ($wantarray) { + return $downgrade -> bnan(), $downgrade -> bnan() + if defined($downgrade); + return $x -> bnan(), $class -> bnan(); + } else { + return $downgrade -> bnan() + if defined($downgrade); + return $x -> bnan(); + } } # Divide by zero and modulo zero. This is handled the same way as in @@ -933,6 +996,11 @@ sub bdiv { } else { $quo = $x -> binf($x -> {sign}); } + + $quo = $downgrade -> new($quo) + if defined($downgrade) && $quo -> is_int(); + $rem = $downgrade -> new($rem) + if $wantarray && defined($downgrade) && $rem -> is_int(); return $wantarray ? ($quo, $rem) : $quo; } @@ -949,6 +1017,11 @@ sub bdiv { my $sign = $x -> bcmp(0) == $y -> bcmp(0) ? '+' : '-'; $quo = $x -> binf($sign); } + + $quo = $downgrade -> new($quo) + if defined($downgrade) && $quo -> is_int(); + $rem = $downgrade -> new($rem) + if $wantarray && defined($downgrade) && $rem -> is_int(); return $wantarray ? ($quo, $rem) : $quo; } @@ -966,12 +1039,18 @@ sub bdiv { $rem = $class -> binf($y -> {sign}); $quo = $x -> bone('-'); } + $quo = $downgrade -> new($quo) + if defined($downgrade) && $quo -> is_int(); + $rem = $downgrade -> new($rem) + if defined($downgrade) && $rem -> is_int(); return ($quo, $rem); } else { if ($y -> is_inf()) { if ($x -> is_nan() || $x -> is_inf()) { + return $downgrade -> bnan() if defined $downgrade; return $x -> bnan(); } else { + return $downgrade -> bzero() if defined $downgrade; return $x -> bzero(); } } @@ -982,7 +1061,11 @@ sub bdiv { # the denominator (divisor) is non-zero. # x == 0? - return wantarray ? ($x, $class->bzero()) : $x if $x->is_zero(); + if ($x->is_zero()) { + return $wantarray ? ($downgrade -> bzero(), $downgrade -> bzero()) + : $downgrade -> bzero() if defined $downgrade; + return $wantarray ? ($x, $class->bzero()) : $x; + } # XXX TODO: list context, upgrade # According to Knuth, this can be optimized by doing gcd twice (for d and n) @@ -1001,13 +1084,14 @@ sub bdiv { $x -> bnorm(); if (wantarray) { my $rem = $x -> copy(); - $x -> bfloor(); - $x -> round(@r); - $rem -> bsub($x -> copy()) -> bmul($y); + $x = $x -> bfloor(); + $x = $x -> round(@r); + $rem = $rem -> bsub($x -> copy()) -> bmul($y); + $x = $downgrade -> new($x) if defined($downgrade) && $x -> is_int(); + $rem = $downgrade -> new($rem) if defined($downgrade) && $rem -> is_int(); return $x, $rem; } else { - $x -> round(@r); - return $x; + return $x -> round(@r); } } @@ -1033,6 +1117,7 @@ sub bmod { # Modulo zero. This is handled the same way as in Math::BigInt -> bmod(). if ($y -> is_zero()) { + return $downgrade -> bzero() if defined $downgrade; return $x; } @@ -1048,8 +1133,10 @@ sub bmod { if ($y -> is_inf()) { if ($x -> is_zero() || $x -> bcmp(0) == $y -> bcmp(0)) { + return $downgrade -> new($x) if defined($downgrade) && $x -> is_int(); return $x; } else { + return $downgrade -> binf($y -> sign()) if defined($downgrade); return $x -> binf($y -> sign()); } } @@ -1057,7 +1144,10 @@ sub bmod { # At this point, both the numerator and denominator are finite numbers, and # the denominator (divisor) is non-zero. - return $x if $x->is_zero(); # 0 / 7 = 0, mod 0 + if ($x->is_zero()) { # 0 / 7 = 0, mod 0 + return $downgrade -> bzero() if defined $downgrade; + return $x; + } # Compute $x - $y * floor($x/$y). This can probably be optimized by working # on a lower level. @@ -1073,7 +1163,10 @@ sub bdec { # decrement value (subtract 1) my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - return $x if $x->{sign} !~ /^[+-]$/; # NaN, inf, -inf + if ($x->{sign} !~ /^[+-]$/) { # NaN, inf, -inf + return $downgrade -> new($x) if defined $downgrade; + return $x; + } if ($x->{sign} eq '-') { $x->{_n} = $LIB->_add($x->{_n}, $x->{_d}); # -5/2 => -7/2 @@ -1094,7 +1187,10 @@ sub binc { # increment value (add 1) my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - return $x if $x->{sign} !~ /^[+-]$/; # NaN, inf, -inf + if ($x->{sign} !~ /^[+-]$/) { # NaN, inf, -inf + return $downgrade -> new($x) if defined $downgrade; + return $x; + } if ($x->{sign} eq '-') { if ($LIB->_acmp($x->{_n}, $x->{_d}) < 0) { @@ -1110,6 +1206,20 @@ sub binc { $x->bnorm()->round(@r); } +sub binv { + my $x = shift; + my @r = @_; + + return $x if $x->modify('binv'); + + return $x if $x -> is_nan(); + return $x -> bzero() if $x -> is_inf(); + return $x -> binf("+") if $x -> is_zero(); + + ($x -> {_n}, $x -> {_d}) = ($x -> {_d}, $x -> {_n}); + $x -> round(@r); +} + ############################################################################## # is_foo methods (the rest is inherited) @@ -1201,6 +1311,53 @@ sub parts { ($n, $d); } +sub dparts { + my $x = shift; + my $class = ref $x; + + croak("dparts() is an instance method") unless $class; + + if ($x -> is_nan()) { + return $class -> bnan(), $class -> bnan() if wantarray; + return $class -> bnan(); + } + + if ($x -> is_inf()) { + return $class -> binf($x -> sign()), $class -> bzero() if wantarray; + return $class -> binf($x -> sign()); + } + + # 355/113 => 3 + 16/113 + + my ($q, $r) = $LIB -> _div($LIB -> _copy($x -> {_n}), $x -> {_d}); + + my $int = Math::BigRat -> new($x -> {sign} . $LIB -> _str($q)); + return $int unless wantarray; + + my $frc = Math::BigRat -> new($x -> {sign} . $LIB -> _str($r), + $LIB -> _str($x -> {_d})); + + return $int, $frc; +} + +sub fparts { + my $x = shift; + my $class = ref $x; + + croak("fparts() is an instance method") unless $class; + + return ($class -> bnan(), + $class -> bnan()) if $x -> is_nan(); + + my $numer = $x -> copy(); + my $denom = $class -> bzero(); + + $denom -> {_n} = $numer -> {_d}; + $numer -> {_d} = $LIB -> _one(); + + return ($numer, $denom); +} + sub length { my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); @@ -1221,37 +1378,52 @@ sub digit { sub bceil { my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); - return $x if ($x->{sign} !~ /^[+-]$/ || # not for NaN, inf - $LIB->_is_one($x->{_d})); # 22/1 => 22, 0/1 => 0 + if ($x->{sign} !~ /^[+-]$/ || # NaN or inf or + $LIB->_is_one($x->{_d})) # integer + { + return $downgrade -> new($x) if defined $downgrade; + return $x; + } $x->{_n} = $LIB->_div($x->{_n}, $x->{_d}); # 22/7 => 3/1 w/ truncate $x->{_d} = $LIB->_one(); # d => 1 $x->{_n} = $LIB->_inc($x->{_n}) if $x->{sign} eq '+'; # +22/7 => 4/1 $x->{sign} = '+' if $x->{sign} eq '-' && $LIB->_is_zero($x->{_n}); # -0 => 0 + return $downgrade -> new($x) if defined $downgrade; $x; } sub bfloor { my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); - return $x if ($x->{sign} !~ /^[+-]$/ || # not for NaN, inf - $LIB->_is_one($x->{_d})); # 22/1 => 22, 0/1 => 0 + if ($x->{sign} !~ /^[+-]$/ || # NaN or inf or + $LIB->_is_one($x->{_d})) # integer + { + return $downgrade -> new($x) if defined $downgrade; + return $x; + } $x->{_n} = $LIB->_div($x->{_n}, $x->{_d}); # 22/7 => 3/1 w/ truncate $x->{_d} = $LIB->_one(); # d => 1 $x->{_n} = $LIB->_inc($x->{_n}) if $x->{sign} eq '-'; # -22/7 => -4/1 + return $downgrade -> new($x) if defined $downgrade; $x; } sub bint { - my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); + my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); - return $x if ($x->{sign} !~ /^[+-]$/ || # +/-inf or NaN - $LIB -> _is_one($x->{_d})); # already an integer + if ($x->{sign} !~ /^[+-]$/ || # NaN or inf or + $LIB->_is_one($x->{_d})) # integer + { + return $downgrade -> new($x) if defined $downgrade; + return $x; + } $x->{_n} = $LIB->_div($x->{_n}, $x->{_d}); # 22/7 => 3/1 w/ truncate $x->{_d} = $LIB->_one(); # d => 1 $x->{sign} = '+' if $x->{sign} eq '-' && $LIB -> _is_zero($x->{_n}); + return $downgrade -> new($x) if defined $downgrade; return $x; } @@ -1279,6 +1451,8 @@ sub bpow { ($class, $x, $y, @r) = objectify(2, @_); } + return $x if $x->modify('bpow'); + # $x and/or $y is a NaN return $x->bnan() if $x->is_nan() || $y->is_nan(); @@ -1304,21 +1478,28 @@ sub bpow { return $x->binf("+"); } - if ($x->is_zero()) { - return $x->binf() if $y->is_negative(); - return $x->bone("+") if $y->is_zero(); + if ($x -> is_zero()) { + return $x -> bone() if $y -> is_zero(); + return $x -> binf() if $y -> is_negative(); return $x; - } elsif ($x->is_one()) { - return $x->round(@r) if $y->is_odd(); # x is -1, y is odd => -1 - return $x->babs()->round(@r); # x is -1, y is even => 1 - } elsif ($y->is_zero()) { - return $x->bone(@r); # x^0 and x != 0 => 1 - } elsif ($y->is_one()) { - return $x->round(@r); # x^1 => x } - # we don't support complex numbers, so return NaN - return $x->bnan() if $x->is_negative() && !$y->is_int(); + # We don't support complex numbers, so upgrade or return NaN. + + if ($x -> is_negative() && !$y -> is_int()) { + return $upgrade -> bpow($upgrade -> new($x), $y, @r) + if defined $upgrade; + return $x -> bnan(); + } + + if ($x -> is_one("+") || $y -> is_one()) { + return $x; + } + + if ($x -> is_one("-")) { + return $x if $y -> is_odd(); + return $x -> bneg(); + } # (a/b)^-(c/d) = (b/a)^(c/d) ($x->{_n}, $x->{_d}) = ($x->{_d}, $x->{_n}) if $y->is_negative(); @@ -1348,11 +1529,11 @@ sub blog { # $x->blog(undef) signals that the base is Euler's number. if (!ref($_[0]) && $_[0] =~ /^[A-Za-z]|::/) { - # E.g., Math::BigFloat->blog(256, 2) + # E.g., Math::BigRat->blog(256, 2) ($class, $x, $base, @r) = defined $_[2] ? objectify(2, @_) : objectify(1, @_); } else { - # E.g., Math::BigFloat::blog(256, 2) or $x->blog(2) + # E.g., Math::BigRat::blog(256, 2) or $x->blog(2) ($class, $x, $base, @r) = defined $_[1] ? objectify(2, @_) : objectify(1, @_); } @@ -1393,20 +1574,50 @@ sub blog { return $x -> binf($sign); } + # Now take care of the cases where $x and/or $base is 1/N. + # + # log(1/N) / log(B) = -log(N)/log(B) + # log(1/N) / log(1/B) = log(N)/log(B) + # log(N) / log(1/B) = -log(N)/log(B) + + my $neg = 0; + if ($x -> numerator() -> is_one()) { + $x -> binv(); + $neg = !$neg; + } + if (defined(blessed($base)) && $base -> isa($class)) { + if ($base -> numerator() -> is_one()) { + $base = $base -> copy() -> binv(); + $neg = !$neg; + } + } + + # disable upgrading and downgrading + + require Math::BigFloat; + my $upg = Math::BigFloat -> upgrade(); + my $dng = Math::BigFloat -> downgrade(); + Math::BigFloat -> upgrade(undef); + Math::BigFloat -> downgrade(undef); + # At this point we are done handling all exception cases and trivial cases. $base = Math::BigFloat -> new($base) if defined $base; + my $xnum = Math::BigFloat -> new($LIB -> _str($x->{_n})); + my $xden = Math::BigFloat -> new($LIB -> _str($x->{_d})); + my $xstr = $xnum -> bdiv($xden) -> blog($base, @r) -> bsstr(); - my $xn = Math::BigFloat -> new($LIB -> _str($x->{_n})); - my $xd = Math::BigFloat -> new($LIB -> _str($x->{_d})); + # reset upgrading and downgrading - my $xtmp = Math::BigRat -> new($xn -> bdiv($xd) -> blog($base, @r) -> bsstr()); + Math::BigFloat -> upgrade($upg); + Math::BigFloat -> downgrade($dng); - $x -> {sign} = $xtmp -> {sign}; - $x -> {_n} = $xtmp -> {_n}; - $x -> {_d} = $xtmp -> {_d}; + my $xobj = Math::BigRat -> new($xstr); + $x -> {sign} = $xobj -> {sign}; + $x -> {_n} = $xobj -> {_n}; + $x -> {_d} = $xobj -> {_d}; - return $x; + return $neg ? $x -> bneg() : $x; } sub bexp { @@ -1513,13 +1724,18 @@ sub bnok { ($class, $x, $y, @r) = objectify(2, @_); } - my $xint = Math::BigInt -> new($x -> bint() -> bsstr()); - my $yint = Math::BigInt -> new($y -> bint() -> bsstr()); + return $x->bnan() if $x->is_nan() || $y->is_nan(); + return $x->bnan() if (($x->is_finite() && !$x->is_int()) || + ($y->is_finite() && !$y->is_int())); + + my $xint = Math::BigInt -> new($x -> bstr()); + my $yint = Math::BigInt -> new($y -> bstr()); $xint -> bnok($yint); + my $xrat = Math::BigRat -> new($xint); - $x -> {sign} = $xint -> {sign}; - $x -> {_n} = $xint -> {_n}; - $x -> {_d} = $xint -> {_d}; + $x -> {sign} = $xrat -> {sign}; + $x -> {_n} = $xrat -> {_n}; + $x -> {_d} = $xrat -> {_d}; return $x; } @@ -1570,7 +1786,7 @@ sub bmodpow { my $yint = Math::BigInt -> new($y -> copy() -> bint()); my $mint = Math::BigInt -> new($m -> copy() -> bint()); - $xint -> bmodpow($y, $m, @r); + $xint -> bmodpow($yint, $mint, @r); my $xtmp = Math::BigRat -> new($xint -> bsstr()); $x -> {sign} = $xtmp -> {sign}; @@ -1592,7 +1808,7 @@ sub bmodinv { my $xint = Math::BigInt -> new($x -> copy() -> bint()); my $yint = Math::BigInt -> new($y -> copy() -> bint()); - $xint -> bmodinv($y, @r); + $xint -> bmodinv($yint, @r); my $xtmp = Math::BigRat -> new($xint -> bsstr()); $x -> {sign} = $xtmp -> {sign}; @@ -1651,7 +1867,7 @@ sub bsqrt { } sub blsft { - my ($class, $x, $y, $b, @r) = objectify(2, @_); + my ($class, $x, $y, $b) = objectify(2, @_); $b = 2 if !defined $b; $b = $class -> new($b) unless ref($b) && $b -> isa($class); @@ -1665,7 +1881,7 @@ sub blsft { } sub brsft { - my ($class, $x, $y, $b, @r) = objectify(2, @_); + my ($class, $x, $y, $b) = objectify(2, @_); $b = 2 if !defined $b; $b = $class -> new($b) unless ref($b) && $b -> isa($class); @@ -1776,15 +1992,24 @@ sub bnot { # round sub round { - $_[0]; + my $x = shift; + return $downgrade -> new($x) if defined($downgrade) && + ($x -> is_int() || $x -> is_inf() || $x -> is_nan()); + $x; } sub bround { - $_[0]; + my $x = shift; + return $downgrade -> new($x) if defined($downgrade) && + ($x -> is_int() || $x -> is_inf() || $x -> is_nan()); + $x; } sub bfround { - $_[0]; + my $x = shift; + return $downgrade -> new($x) if defined($downgrade) && + ($x -> is_int() || $x -> is_inf() || $x -> is_nan()); + $x; } ############################################################################## @@ -1803,9 +2028,9 @@ sub bcmp { if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/) { # $x is NaN and/or $y is NaN - return undef if $x->{sign} eq $nan || $y->{sign} eq $nan; + return if $x->{sign} eq $nan || $y->{sign} eq $nan; # $x and $y are both either +inf or -inf - return 0 if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/; + return 0 if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/; # $x = +inf and $y < +inf return +1 if $x->{sign} eq '+inf'; # $x = -inf and $y > -inf @@ -1850,9 +2075,9 @@ sub bacmp { if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/)) { # handle +-inf and NaN - return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); - return 0 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/; - return 1 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} !~ /^[+-]inf$/; + return if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); + return 0 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/; + return 1 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} !~ /^[+-]inf$/; return -1; } @@ -1864,7 +2089,7 @@ sub bacmp { sub beq { my $self = shift; my $selfref = ref $self; - my $class = $selfref || $self; + #my $class = $selfref || $self; croak 'beq() is an instance method, not a class method' unless $selfref; croak 'Wrong number of arguments for beq()' unless @_ == 1; @@ -1876,7 +2101,7 @@ sub beq { sub bne { my $self = shift; my $selfref = ref $self; - my $class = $selfref || $self; + #my $class = $selfref || $self; croak 'bne() is an instance method, not a class method' unless $selfref; croak 'Wrong number of arguments for bne()' unless @_ == 1; @@ -1888,7 +2113,7 @@ sub bne { sub blt { my $self = shift; my $selfref = ref $self; - my $class = $selfref || $self; + #my $class = $selfref || $self; croak 'blt() is an instance method, not a class method' unless $selfref; croak 'Wrong number of arguments for blt()' unless @_ == 1; @@ -1900,7 +2125,7 @@ sub blt { sub ble { my $self = shift; my $selfref = ref $self; - my $class = $selfref || $self; + #my $class = $selfref || $self; croak 'ble() is an instance method, not a class method' unless $selfref; croak 'Wrong number of arguments for ble()' unless @_ == 1; @@ -1912,7 +2137,7 @@ sub ble { sub bgt { my $self = shift; my $selfref = ref $self; - my $class = $selfref || $self; + #my $class = $selfref || $self; croak 'bgt() is an instance method, not a class method' unless $selfref; croak 'Wrong number of arguments for bgt()' unless @_ == 1; @@ -1924,7 +2149,7 @@ sub bgt { sub bge { my $self = shift; my $selfref = ref $self; - my $class = $selfref || $self; + #my $class = $selfref || $self; croak 'bge() is an instance method, not a class method' unless $selfref; @@ -1943,7 +2168,17 @@ sub numify { # Non-finite number. - return $x->bstr() if $x->{sign} !~ /^[+-]$/; + if ($x -> is_nan()) { + require Math::Complex; + my $inf = $Math::Complex::Inf; + return $inf - $inf; + } + + if ($x -> is_inf()) { + require Math::Complex; + my $inf = $Math::Complex::Inf; + return $x -> is_negative() ? -$inf : $inf; + } # Finite number. @@ -1956,34 +2191,70 @@ sub numify { } sub as_int { - my ($self, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); + my ($class, $x) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - # NaN, inf etc - return Math::BigInt->new($x->{sign}) if $x->{sign} !~ /^[+-]$/; + return $x -> copy() if $x -> isa("Math::BigInt"); - my $u = Math::BigInt->bzero(); - $u->{value} = $LIB->_div($LIB->_copy($x->{_n}), $x->{_d}); # 22/7 => 3 - $u->bneg if $x->{sign} eq '-'; # no negative zero - $u; + # disable upgrading and downgrading + + require Math::BigInt; + my $upg = Math::BigInt -> upgrade(); + my $dng = Math::BigInt -> downgrade(); + Math::BigInt -> upgrade(undef); + Math::BigInt -> downgrade(undef); + + my $y; + if ($x -> is_inf()) { + $y = Math::BigInt -> binf($x->sign()); + } elsif ($x -> is_nan()) { + $y = Math::BigInt -> bnan(); + } else { + my $int = $LIB -> _div($LIB -> _copy($x->{_n}), $x->{_d}); # 22/7 => 3 + $y = Math::BigInt -> new($LIB -> _str($int)); + $y = $y -> bneg() if $x -> is_neg(); + } + + # reset upgrading and downgrading + + Math::BigInt -> upgrade($upg); + Math::BigInt -> downgrade($dng); + + return $y; } sub as_float { - # return N/D as Math::BigFloat + my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); - # set up parameters - my ($class, $x, @r) = (ref($_[0]), @_); - # objectify is costly, so avoid it - ($class, $x, @r) = objectify(1, @_) unless ref $_[0]; + return $x -> copy() if $x -> isa("Math::BigFloat"); - # NaN, inf etc - return Math::BigFloat->new($x->{sign}) if $x->{sign} !~ /^[+-]$/; + # disable upgrading and downgrading - my $xd = Math::BigFloat -> new($LIB -> _str($x->{_d})); - my $xflt = Math::BigFloat -> new($LIB -> _str($x->{_n})); - $xflt -> {sign} = $x -> {sign}; - $xflt -> bdiv($xd, @r); + require Math::BigFloat; + my $upg = Math::BigFloat -> upgrade(); + my $dng = Math::BigFloat -> downgrade(); + Math::BigFloat -> upgrade(undef); + Math::BigFloat -> downgrade(undef); + + my $y; + if ($x -> is_inf()) { + $y = Math::BigFloat -> binf($x->sign()); + } elsif ($x -> is_nan()) { + $y = Math::BigFloat -> bnan(); + } else { + $y = Math::BigFloat -> new($LIB -> _str($x->{_n})); + $y -> {sign} = $x -> {sign}; + unless ($LIB -> _is_one($x->{_d})) { + my $xd = Math::BigFloat -> new($LIB -> _str($x->{_d})); + $y -> bdiv($xd, @r); + } + } + + # reset upgrading and downgrading - return $xflt; + Math::BigFloat -> upgrade($upg); + Math::BigFloat -> downgrade($dng); + + return $y; } sub as_bin { @@ -2019,18 +2290,27 @@ sub as_oct { sub from_hex { my $class = shift; - $class->new(@_); + # The relationship should probably go the otherway, i.e, that new() calls + # from_hex(). Fixme! + my ($x, @r) = @_; + $x =~ s|^\s*(?:0?[Xx]_*)?|0x|; + $class->new($x, @r); } sub from_bin { my $class = shift; - $class->new(@_); + # The relationship should probably go the otherway, i.e, that new() calls + # from_bin(). Fixme! + my ($x, @r) = @_; + $x =~ s|^\s*(?:0?[Bb]_*)?|0b|; + $class->new($x, @r); } sub from_oct { my $class = shift; + # Why is this different from from_hex() and from_bin()? Fixme! my @parts; for my $c (@_) { push @parts, Math::BigInt->from_oct($c); @@ -2043,57 +2323,101 @@ sub from_oct { sub import { my $class = shift; - my $l = scalar @_; - my $lib = ''; my @a; - my $try = 'try'; - - for (my $i = 0; $i < $l ; $i++) { - if ($_[$i] eq ':constant') { - # this rest causes overlord er load to step in - overload::constant float => sub { $class->new(shift); }; + my @a; # unrecognized arguments + my $lib_param = ''; + my $lib_value = ''; + + while (@_) { + my $param = shift; + + # Enable overloading of constants. + + if ($param eq ':constant') { + overload::constant + + integer => sub { + $class -> new(shift); + }, + + float => sub { + $class -> new(shift); + }, + + binary => sub { + # E.g., a literal 0377 shall result in an object whose value + # is decimal 255, but new("0377") returns decimal 377. + return $class -> from_oct($_[0]) if $_[0] =~ /^0_*[0-7]/; + $class -> new(shift); + }; + next; } - # elsif ($_[$i] eq 'upgrade') - # { - # # this causes upgrading - # $upgrade = $_[$i+1]; # or undef to disable - # $i++; - # } - elsif ($_[$i] eq 'downgrade') { - # this causes downgrading - $downgrade = $_[$i+1]; # or undef to disable - $i++; - } elsif ($_[$i] =~ /^(lib|try|only)\z/) { - $lib = $_[$i+1] || ''; # default Calc - $try = $1; # lib, try or only - $i++; - } elsif ($_[$i] eq 'with') { - # this argument is no longer used - #$LIB = $_[$i+1] || 'Math::BigInt::Calc'; # default Math::BigInt::Calc - $i++; - } else { - push @a, $_[$i]; + + # Upgrading. + + if ($param eq 'upgrade') { + $class -> upgrade(shift); + next; } - } - require Math::BigInt; - # let use Math::BigInt lib => 'GMP'; use Math::BigRat; still have GMP - if ($lib ne '') { - my @c = split /\s*,\s*/, $lib; - foreach (@c) { - $_ =~ tr/a-zA-Z0-9://cd; # limit to sane characters + # Downgrading. + + if ($param eq 'downgrade') { + $class -> downgrade(shift); + next; } - $lib = join(",", @c); + + # Accuracy. + + if ($param eq 'accuracy') { + $class -> accuracy(shift); + next; + } + + # Precision. + + if ($param eq 'precision') { + $class -> precision(shift); + next; + } + + # Rounding mode. + + if ($param eq 'round_mode') { + $class -> round_mode(shift); + next; + } + + # Backend library. + + if ($param =~ /^(lib|try|only)\z/) { + # alternative library + $lib_param = $param; # "lib", "try", or "only" + $lib_value = shift; + next; + } + + if ($param eq 'with') { + # alternative class for our private parts() + # XXX: no longer supported + # $LIB = shift() || 'Calc'; + # carp "'with' is no longer supported, use 'lib', 'try', or 'only'"; + shift; + next; + } + + # Unrecognized parameter. + + push @a, $param; } - my @import = ('objectify'); - push @import, $try => $lib if $lib ne ''; - # LIB already loaded, so feed it our lib arguments - Math::BigInt->import(@import); + require Math::BigInt; - $LIB = Math::BigFloat->config("lib"); + my @import = ('objectify'); + push @import, $lib_param, $lib_value if $lib_param ne ''; + Math::BigInt -> import(@import); - # register us with LIB to get notified of future lib changes - Math::BigInt::_register_callback($class, sub { $LIB = $_[0]; }); + # find out which one was actually loaded + $LIB = Math::BigInt -> config("lib"); # any non :constant stuff is handled by Exporter (loaded by parent class) # even if @_ is empty, to give it a chance @@ -2109,7 +2433,7 @@ __END__ =head1 NAME -Math::BigRat - Arbitrary big rational numbers +Math::BigRat - arbitrary size rational number math package =head1 SYNOPSIS @@ -2201,6 +2525,16 @@ Returns a copy of the denominator (the part under the line) as positive BigInt. Return a list consisting of (signed) numerator and (unsigned) denominator as BigInts. +=item dparts() + +Returns the integer part and the fraction part. + +=item fparts() + +Returns the smallest possible numerator and denominator so that the numerator +divided by the denominator gives back the original value. For finite numbers, +both values are integers. Mnemonic: fraction. + =item numify() my $y = $x->numify(); @@ -2513,7 +2847,13 @@ Subtracts $y from $x and returns the result. In scalar context, divides $x by $y and returns the result. In list context, does floored division (F-division), returning an integer $q and a remainder $r so that $x = $q * $y + $r. The remainer (modulo) is equal to what is returned -by C<$x->bmod($y)>. +by C<< $x->bmod($y) >>. + +=item binv() + + $x->binv(); + +Inverse of $x. =item bdec() @@ -2695,6 +3035,70 @@ supported. =back +=head1 NUMERIC LITERALS + +After C<use Math::BigRat ':constant'> all numeric literals in the given scope +are converted to C<Math::BigRat> objects. This conversion happens at compile +time. Every non-integer is convert to a NaN. + +For example, + + perl -MMath::BigRat=:constant -le 'print 2**150' + +prints the exact value of C<2**150>. Note that without conversion of constants +to objects the expression C<2**150> is calculated using Perl scalars, which +leads to an inaccurate result. + +Please note that strings are not affected, so that + + use Math::BigRat qw/:constant/; + + $x = "1234567890123456789012345678901234567890" + + "123456789123456789"; + +does give you what you expect. You need an explicit Math::BigRat->new() around +at least one of the operands. You should also quote large constants to prevent +loss of precision: + + use Math::BigRat; + + $x = Math::BigRat->new("1234567889123456789123456789123456789"); + +Without the quotes Perl first converts the large number to a floating point +constant at compile time, and then converts the result to a Math::BigRat object +at run time, which results in an inaccurate result. + +=head2 Hexadecimal, octal, and binary floating point literals + +Perl (and this module) accepts hexadecimal, octal, and binary floating point +literals, but use them with care with Perl versions before v5.32.0, because some +versions of Perl silently give the wrong result. Below are some examples of +different ways to write the number decimal 314. + +Hexadecimal floating point literals: + + 0x1.3ap+8 0X1.3AP+8 + 0x1.3ap8 0X1.3AP8 + 0x13a0p-4 0X13A0P-4 + +Octal floating point literals (with "0" prefix): + + 01.164p+8 01.164P+8 + 01.164p8 01.164P8 + 011640p-4 011640P-4 + +Octal floating point literals (with "0o" prefix) (requires v5.34.0): + + 0o1.164p+8 0O1.164P+8 + 0o1.164p8 0O1.164P8 + 0o11640p-4 0O11640P-4 + +Binary floating point literals: + + 0b1.0011101p+8 0B1.0011101P+8 + 0b1.0011101p8 0B1.0011101P8 + 0b10011101000p-2 0B10011101000P-2 + =head1 BUGS Please report any bugs or feature requests to @@ -2714,43 +3118,25 @@ You can also look for information at: =over 4 -=item * RT: CPAN's request tracker - -L<https://rt.cpan.org/Public/Dist/Display.html?Name=Math-BigRat> - -=item * AnnoCPAN: Annotated CPAN documentation +=item * GitHub -L<http://annocpan.org/dist/Math-BigRat> +L<https://github.com/pjacklam/p5-Math-BigRat> -=item * CPAN Ratings +=item * RT: CPAN's request tracker -L<http://cpanratings.perl.org/dist/Math-BigRat> +L<https://rt.cpan.org/Dist/Display.html?Name=Math-BigRat> -=item * Search CPAN +=item * MetaCPAN -L<http://search.cpan.org/dist/Math-BigRat/> +L<https://metacpan.org/release/Math-BigRat> =item * CPAN Testers Matrix L<http://matrix.cpantesters.org/?dist=Math-BigRat> -=item * The Bignum mailing list - -=over 4 - -=item * Post to mailing list - -C<bignum at lists.scsys.co.uk> - -=item * View mailing list - -L<http://lists.scsys.co.uk/pipermail/bignum/> - -=item * Subscribe/Unsubscribe - -L<http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/bignum> +=item * CPAN Ratings -=back +L<https://cpanratings.perl.org/dist/Math-BigRat> =back @@ -2774,7 +3160,7 @@ Tels L<http://bloodgate.com/> 2001-2009. =item * -Maintained by Peter John Acklam <pjacklam@online.no> 2011- +Maintained by Peter John Acklam <pjacklam@gmail.com> 2011- =back diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigRat/Trace.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigRat/Trace.pm new file mode 100755 index 0000000000..e61df01317 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigRat/Trace.pm @@ -0,0 +1,76 @@ +# -*- mode: perl; -*- + +package Math::BigRat::Trace; + +use strict; +use warnings; + +use Exporter; +use Math::BigRat; + +our @ISA = qw(Exporter Math::BigRat); + +our $VERSION = '0.66'; + +use overload; # inherit overload from Math::BigRat + +# Globals +our $accuracy = undef; +our $precision = undef; +our $round_mode = 'even'; +our $div_scale = 40; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + + my $value = shift; + + my $a = $accuracy; + $a = $_[0] if defined $_[0]; + + my $p = $precision; + $p = $_[1] if defined $_[1]; + + my $self = $class -> SUPER::new($value, $a, $p, $round_mode); + + printf "Math::BigRat new '%s' => '%s' (%s)\n", + $value, $self, ref($self); + + return $self; +} + +sub import { + my $class = shift; + + printf "%s -> import(%s)\n", $class, join(", ", @_); + + # we catch the constants, the rest goes to parent + + my $constant = grep { $_ eq ':constant' } @_; + my @a = grep { $_ ne ':constant' } @_; + + if ($constant) { + overload::constant + + integer => sub { + $class -> new(shift); + }, + + float => sub { + $class -> new(shift); + }, + + binary => sub { + # E.g., a literal 0377 shall result in an object whose value + # is decimal 255, but new("0377") returns decimal 377. + return $class -> from_oct($_[0]) if $_[0] =~ /^0_*[0-7]/; + $class -> new(shift); + }; + } + + $class -> SUPER::import(@a); # need it for subclasses + #$self -> export_to_level(1, $class, @_); # need this ? +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/Complex.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/Complex.pm index 6cab2689bd..e6d15b70b9 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/Complex.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/Complex.pm @@ -10,7 +10,7 @@ package Math::Complex; { use 5.006; } use strict; -our $VERSION = 1.59_02; +our $VERSION = 1.62; use Config; @@ -1847,7 +1847,7 @@ number mathematicians call C<j> such that: is a simple matter of writing: - $j = ((root(1, 3))[1]; + $j = (root(1, 3))[1]; The I<k>th root for C<z = [r,t]> is given by: diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/Trig.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/Trig.pm index 1d9612a41c..218ab690a5 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/Trig.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/Trig.pm @@ -15,7 +15,7 @@ require Exporter; our @ISA = qw(Exporter); -our $VERSION = 1.23; +our $VERSION = 1.62; my @angcnv = qw(rad2deg rad2grad deg2rad deg2grad @@ -47,8 +47,9 @@ my @pi = qw(pi pi2 pi4 pip2 pip4); our @EXPORT_OK = (@rdlcnv, @greatcircle, @pi, 'Inf'); # See e.g. the following pages: -# http://www.movable-type.co.uk/scripts/LatLong.html -# http://williams.best.vwh.net/avform.htm +# https://www.movable-type.co.uk/scripts/latlong.html +# https://edwilliams.org/avform.htm +# https://en.wikipedia.org/wiki/Great-circle_distance our %EXPORT_TAGS = ('radial' => [ @rdlcnv ], 'great_circle' => [ @greatcircle ], @@ -153,12 +154,19 @@ sub great_circle_distance { $rho = 1 unless defined $rho; # Default to the unit sphere. - my $lat0 = pip2 - $phi0; - my $lat1 = pip2 - $phi1; + my $dphi = $phi1 - $phi0; + my $dtheta = $theta1 - $theta0; + + # A formula that is accurate for all distances is the following special + # case of the Vincenty formula for an ellipsoid with equal major and minor + # axes. See + # https://en.wikipedia.org/wiki/Great-circle_distance#Computational_formulas - return $rho * - acos_real( cos( $lat0 ) * cos( $lat1 ) * cos( $theta0 - $theta1 ) + - sin( $lat0 ) * sin( $lat1 ) ); + my $c1 = sin($phi1) * sin($dtheta); + my $c2 = sin($phi1) * cos($dtheta); + my $c3 = sin($phi0) * cos($phi1) - cos($phi0) * $c2; + my $c4 = cos($phi0) * cos($phi1) + sin($phi0) * $c2; + return $rho * atan2(sqrt($c1 * $c1 + $c3 * $c3), $c4); } sub great_circle_direction { @@ -247,7 +255,7 @@ Math::Trig - trigonometric functions $rad = deg2rad(120); - # Import constants pi2, pip2, pip4 (2*pi, pi/2, pi/4). + # Import constants pi2, pi4, pip2, pip4 (2*pi, 4*pi, pi/2, pi/4). use Math::Trig ':pi'; # Import the conversions between cartesian/spherical/cylindrical. @@ -417,7 +425,7 @@ and the imaginary part of approximately C<-1.317>. =back The full circle is 2 I<pi> radians or I<360> degrees or I<400> gradians. -The result is by default wrapped to be inside the [0, {2pi,360,400}[ circle. +The result is by default wrapped to be inside the [0, {2pi,360,400}] circle. If you don't want this, supply a true second argument: $zillions_of_radians = deg2rad($zillions_of_degrees, 1); @@ -465,15 +473,15 @@ B<All angles are in radians>. B<Cartesian> coordinates are the usual rectangular I<(x, y, z)>-coordinates. -Spherical coordinates, I<(rho, theta, pi)>, are three-dimensional +Spherical coordinates, I<(rho, theta, phi)>, are three-dimensional coordinates which define a point in three-dimensional space. They are based on a sphere surface. The radius of the sphere is B<rho>, also known as the I<radial> coordinate. The angle in the I<xy>-plane (around the I<z>-axis) is B<theta>, also known as the I<azimuthal> coordinate. The angle from the I<z>-axis is B<phi>, also known as the -I<polar> coordinate. The North Pole is therefore I<0, 0, rho>, and -the Gulf of Guinea (think of the missing big chunk of Africa) I<0, -pi/2, rho>. In geographical terms I<phi> is latitude (northward +I<polar> coordinate. The North Pole is therefore I<rho, 0, 0>, and +the Gulf of Guinea (think of the missing big chunk of Africa) I<rho, +0, pi/2>. In geographical terms I<phi> is latitude (northward positive, southward negative) and I<theta> is longitude (eastward positive, westward negative). @@ -537,26 +545,19 @@ points. =head2 great_circle_distance -You can compute spherical distances, called B<great circle distances>, -by importing the great_circle_distance() function: +Returns the great circle distance between two points on a sphere. - use Math::Trig 'great_circle_distance'; + $distance = great_circle_distance($theta0, $phi0, $theta1, $phi1, [, $rho]); - $distance = great_circle_distance($theta0, $phi0, $theta1, $phi1, [, $rho]); +Where ($theta0, $phi0) and ($theta1, $phi1) are the spherical coordinates of +the two points, respectively. The distance is in C<$rho> units. The C<$rho> +is optional. It defaults to 1 (the unit sphere). -The I<great circle distance> is the shortest distance between two -points on a sphere. The distance is in C<$rho> units. The C<$rho> is -optional, it defaults to 1 (the unit sphere), therefore the distance -defaults to radians. - -If you think geographically the I<theta> are longitudes: zero at the -Greenwhich meridian, eastward positive, westward negative -- and the -I<phi> are latitudes: zero at the North Pole, northward positive, -southward negative. B<NOTE>: this formula thinks in mathematics, not -geographically: the I<phi> zero is at the North Pole, not at the -Equator on the west coast of Africa (Bay of Guinea). You need to -subtract your geographical coordinates from I<pi/2> (also known as 90 -degrees). +If you are using geographic coordinates, latitude and longitude, you need to +adjust for the fact that latitude is zero at the equator increasing towards +the north and decreasing towards the south. Assuming ($lat0, $lon0) and +($lat1, $lon1) are the geographic coordinates in radians of the two points, +the distance can be computed with $distance = great_circle_distance($lon0, pi/2 - $lat0, $lon1, pi/2 - $lat1, $rho); @@ -617,15 +618,22 @@ The great_circle_midpoint() is just a special case of ($thetai, $phii) = great_circle_waypoint($theta0, $phi0, $theta1, $phi1, $way); -Where the $way is a value from zero ($theta0, $phi0) to one ($theta1, -$phi1). Note that antipodal points (where their distance is I<pi> -radians) do not have waypoints between them (they would have an an -"equator" between them), and therefore C<undef> is returned for -antipodal points. If the points are the same and the distance -therefore zero and all waypoints therefore identical, the first point -(either point) is returned. +Where $way indicates the position of the waypoint along the great +circle arc through the starting point ($theta0, $phi0) and the end +point ($theta1, $phi1) relative to the distance from the starting +point to the end point. So $way = 0 gives the starting point, $way = 1 +gives the end point, $way < 0 gives a point "behind" the starting +point, and $way > 1 gives a point beyond the end point. $way defaults +to 0.5 if not given. + +Note that antipodal points (where their distance is I<pi> radians) do +not have unique waypoints between them, and therefore C<undef> is +returned in such cases. If the points are the same, so the distance +between them is zero, all waypoints are identical to the starting/end +point. -The thetas, phis, direction, and distance in the above are all in radians. +The thetas, phis, direction, and distance in the above are all in +radians. You can import all the great circle formulas by @@ -661,11 +669,13 @@ straight north being zero, straight east being pi/2). The midpoint between London and Tokyo being - use Math::Trig qw(great_circle_midpoint); + use Math::Trig qw(great_circle_midpoint rad2deg); my @M = great_circle_midpoint(@L, @T); + sub SWNE { rad2deg( $_[0] ), 90 - rad2deg( $_[1] ) } + my @lonlat = SWNE(@M); -or about 69 N 89 E, in the frozen wastes of Siberia. +or about 69 N 89 E, on the Putorana Plateau of Siberia. B<NOTE>: you B<cannot> get from A to B like this: @@ -743,6 +753,8 @@ an answer instead of giving a fatal runtime error. Do not attempt navigation using these formulas. +=head1 SEE ALSO + L<Math::Complex> =head1 AUTHORS |