1b8851fccSafresh1package Math::BigFloat; 2b8851fccSafresh1 3b8851fccSafresh1# 4b8851fccSafresh1# Mike grinned. 'Two down, infinity to go' - Mike Nostrus in 'Before and After' 5b8851fccSafresh1# 6b8851fccSafresh1 79f11ffb7Safresh1# The following hash values are used internally: 8*3d61058aSafresh1# 9*3d61058aSafresh1# sign : "+", "-", "+inf", "-inf", or "NaN" 10*3d61058aSafresh1# _m : absolute value of mantissa ($LIB thingy) 11*3d61058aSafresh1# _es : sign of exponent ("+" or "-") 12*3d61058aSafresh1# _e : absolute value of exponent ($LIB thingy) 13*3d61058aSafresh1# accuracy : accuracy (scalar) 14*3d61058aSafresh1# precision : precision (scalar) 15b8851fccSafresh1 16b8851fccSafresh1use 5.006001; 17b8851fccSafresh1use strict; 18b8851fccSafresh1use warnings; 19b8851fccSafresh1 20b46d8ef2Safresh1use Carp qw< carp croak >; 21eac174f2Safresh1use Scalar::Util qw< blessed >; 22eac174f2Safresh1use Math::BigInt qw< >; 239f11ffb7Safresh1 24*3d61058aSafresh1our $VERSION = '2.003002'; 25eac174f2Safresh1$VERSION =~ tr/_//d; 26b8851fccSafresh1 2756d68f1eSafresh1require Exporter; 28b8851fccSafresh1our @ISA = qw/Math::BigInt/; 29b8851fccSafresh1our @EXPORT_OK = qw/bpi/; 30b8851fccSafresh1 31b8851fccSafresh1# $_trap_inf/$_trap_nan are internal and should never be accessed from outside 32b8851fccSafresh1our ($AUTOLOAD, $accuracy, $precision, $div_scale, $round_mode, $rnd_mode, 33b8851fccSafresh1 $upgrade, $downgrade, $_trap_nan, $_trap_inf); 34b8851fccSafresh1 35b8851fccSafresh1use overload 369f11ffb7Safresh1 379f11ffb7Safresh1 # overload key: with_assign 389f11ffb7Safresh1 399f11ffb7Safresh1 '+' => sub { $_[0] -> copy() -> badd($_[1]); }, 409f11ffb7Safresh1 419f11ffb7Safresh1 '-' => sub { my $c = $_[0] -> copy(); 429f11ffb7Safresh1 $_[2] ? $c -> bneg() -> badd($_[1]) 439f11ffb7Safresh1 : $c -> bsub($_[1]); }, 449f11ffb7Safresh1 459f11ffb7Safresh1 '*' => sub { $_[0] -> copy() -> bmul($_[1]); }, 469f11ffb7Safresh1 479f11ffb7Safresh1 '/' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bdiv($_[0]) 489f11ffb7Safresh1 : $_[0] -> copy() -> bdiv($_[1]); }, 499f11ffb7Safresh1 509f11ffb7Safresh1 '%' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bmod($_[0]) 519f11ffb7Safresh1 : $_[0] -> copy() -> bmod($_[1]); }, 529f11ffb7Safresh1 539f11ffb7Safresh1 '**' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bpow($_[0]) 549f11ffb7Safresh1 : $_[0] -> copy() -> bpow($_[1]); }, 559f11ffb7Safresh1 56*3d61058aSafresh1 '<<' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bblsft($_[0]) 57*3d61058aSafresh1 : $_[0] -> copy() -> bblsft($_[1]); }, 589f11ffb7Safresh1 59*3d61058aSafresh1 '>>' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bbrsft($_[0]) 60*3d61058aSafresh1 : $_[0] -> copy() -> bbrsft($_[1]); }, 619f11ffb7Safresh1 629f11ffb7Safresh1 # overload key: assign 639f11ffb7Safresh1 649f11ffb7Safresh1 '+=' => sub { $_[0] -> badd($_[1]); }, 659f11ffb7Safresh1 669f11ffb7Safresh1 '-=' => sub { $_[0] -> bsub($_[1]); }, 679f11ffb7Safresh1 689f11ffb7Safresh1 '*=' => sub { $_[0] -> bmul($_[1]); }, 699f11ffb7Safresh1 709f11ffb7Safresh1 '/=' => sub { scalar $_[0] -> bdiv($_[1]); }, 719f11ffb7Safresh1 729f11ffb7Safresh1 '%=' => sub { $_[0] -> bmod($_[1]); }, 739f11ffb7Safresh1 749f11ffb7Safresh1 '**=' => sub { $_[0] -> bpow($_[1]); }, 759f11ffb7Safresh1 76*3d61058aSafresh1 '<<=' => sub { $_[0] -> bblsft($_[1]); }, 779f11ffb7Safresh1 78*3d61058aSafresh1 '>>=' => sub { $_[0] -> bbrsft($_[1]); }, 799f11ffb7Safresh1 809f11ffb7Safresh1# 'x=' => sub { }, 819f11ffb7Safresh1 829f11ffb7Safresh1# '.=' => sub { }, 839f11ffb7Safresh1 849f11ffb7Safresh1 # overload key: num_comparison 859f11ffb7Safresh1 869f11ffb7Safresh1 '<' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> blt($_[0]) 879f11ffb7Safresh1 : $_[0] -> blt($_[1]); }, 889f11ffb7Safresh1 899f11ffb7Safresh1 '<=' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> ble($_[0]) 909f11ffb7Safresh1 : $_[0] -> ble($_[1]); }, 919f11ffb7Safresh1 929f11ffb7Safresh1 '>' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bgt($_[0]) 939f11ffb7Safresh1 : $_[0] -> bgt($_[1]); }, 949f11ffb7Safresh1 959f11ffb7Safresh1 '>=' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bge($_[0]) 969f11ffb7Safresh1 : $_[0] -> bge($_[1]); }, 979f11ffb7Safresh1 989f11ffb7Safresh1 '==' => sub { $_[0] -> beq($_[1]); }, 999f11ffb7Safresh1 1009f11ffb7Safresh1 '!=' => sub { $_[0] -> bne($_[1]); }, 1019f11ffb7Safresh1 1029f11ffb7Safresh1 # overload key: 3way_comparison 1039f11ffb7Safresh1 1049f11ffb7Safresh1 '<=>' => sub { my $cmp = $_[0] -> bcmp($_[1]); 1059f11ffb7Safresh1 defined($cmp) && $_[2] ? -$cmp : $cmp; }, 1069f11ffb7Safresh1 1079f11ffb7Safresh1 'cmp' => sub { $_[2] ? "$_[1]" cmp $_[0] -> bstr() 1089f11ffb7Safresh1 : $_[0] -> bstr() cmp "$_[1]"; }, 1099f11ffb7Safresh1 1109f11ffb7Safresh1 # overload key: str_comparison 1119f11ffb7Safresh1 1129f11ffb7Safresh1# 'lt' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrlt($_[0]) 1139f11ffb7Safresh1# : $_[0] -> bstrlt($_[1]); }, 1149f11ffb7Safresh1# 1159f11ffb7Safresh1# 'le' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrle($_[0]) 1169f11ffb7Safresh1# : $_[0] -> bstrle($_[1]); }, 1179f11ffb7Safresh1# 1189f11ffb7Safresh1# 'gt' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrgt($_[0]) 1199f11ffb7Safresh1# : $_[0] -> bstrgt($_[1]); }, 1209f11ffb7Safresh1# 1219f11ffb7Safresh1# 'ge' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrge($_[0]) 1229f11ffb7Safresh1# : $_[0] -> bstrge($_[1]); }, 1239f11ffb7Safresh1# 1249f11ffb7Safresh1# 'eq' => sub { $_[0] -> bstreq($_[1]); }, 1259f11ffb7Safresh1# 1269f11ffb7Safresh1# 'ne' => sub { $_[0] -> bstrne($_[1]); }, 1279f11ffb7Safresh1 1289f11ffb7Safresh1 # overload key: binary 1299f11ffb7Safresh1 1309f11ffb7Safresh1 '&' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> band($_[0]) 1319f11ffb7Safresh1 : $_[0] -> copy() -> band($_[1]); }, 1329f11ffb7Safresh1 1339f11ffb7Safresh1 '&=' => sub { $_[0] -> band($_[1]); }, 1349f11ffb7Safresh1 1359f11ffb7Safresh1 '|' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bior($_[0]) 1369f11ffb7Safresh1 : $_[0] -> copy() -> bior($_[1]); }, 1379f11ffb7Safresh1 1389f11ffb7Safresh1 '|=' => sub { $_[0] -> bior($_[1]); }, 1399f11ffb7Safresh1 1409f11ffb7Safresh1 '^' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bxor($_[0]) 1419f11ffb7Safresh1 : $_[0] -> copy() -> bxor($_[1]); }, 1429f11ffb7Safresh1 1439f11ffb7Safresh1 '^=' => sub { $_[0] -> bxor($_[1]); }, 1449f11ffb7Safresh1 1459f11ffb7Safresh1# '&.' => sub { }, 1469f11ffb7Safresh1 1479f11ffb7Safresh1# '&.=' => sub { }, 1489f11ffb7Safresh1 1499f11ffb7Safresh1# '|.' => sub { }, 1509f11ffb7Safresh1 1519f11ffb7Safresh1# '|.=' => sub { }, 1529f11ffb7Safresh1 1539f11ffb7Safresh1# '^.' => sub { }, 1549f11ffb7Safresh1 1559f11ffb7Safresh1# '^.=' => sub { }, 1569f11ffb7Safresh1 1579f11ffb7Safresh1 # overload key: unary 1589f11ffb7Safresh1 1599f11ffb7Safresh1 'neg' => sub { $_[0] -> copy() -> bneg(); }, 1609f11ffb7Safresh1 1619f11ffb7Safresh1# '!' => sub { }, 1629f11ffb7Safresh1 1639f11ffb7Safresh1 '~' => sub { $_[0] -> copy() -> bnot(); }, 1649f11ffb7Safresh1 1659f11ffb7Safresh1# '~.' => sub { }, 1669f11ffb7Safresh1 1679f11ffb7Safresh1 # overload key: mutators 1689f11ffb7Safresh1 1699f11ffb7Safresh1 '++' => sub { $_[0] -> binc() }, 1709f11ffb7Safresh1 1719f11ffb7Safresh1 '--' => sub { $_[0] -> bdec() }, 1729f11ffb7Safresh1 1739f11ffb7Safresh1 # overload key: func 1749f11ffb7Safresh1 1759f11ffb7Safresh1 'atan2' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> batan2($_[0]) 1769f11ffb7Safresh1 : $_[0] -> copy() -> batan2($_[1]); }, 1779f11ffb7Safresh1 1789f11ffb7Safresh1 'cos' => sub { $_[0] -> copy() -> bcos(); }, 1799f11ffb7Safresh1 1809f11ffb7Safresh1 'sin' => sub { $_[0] -> copy() -> bsin(); }, 1819f11ffb7Safresh1 1829f11ffb7Safresh1 'exp' => sub { $_[0] -> copy() -> bexp($_[1]); }, 1839f11ffb7Safresh1 1849f11ffb7Safresh1 'abs' => sub { $_[0] -> copy() -> babs(); }, 1859f11ffb7Safresh1 1869f11ffb7Safresh1 'log' => sub { $_[0] -> copy() -> blog(); }, 1879f11ffb7Safresh1 1889f11ffb7Safresh1 'sqrt' => sub { $_[0] -> copy() -> bsqrt(); }, 1899f11ffb7Safresh1 1909f11ffb7Safresh1 'int' => sub { $_[0] -> copy() -> bint(); }, 1919f11ffb7Safresh1 1929f11ffb7Safresh1 # overload key: conversion 1939f11ffb7Safresh1 1949f11ffb7Safresh1 'bool' => sub { $_[0] -> is_zero() ? '' : 1; }, 1959f11ffb7Safresh1 1969f11ffb7Safresh1 '""' => sub { $_[0] -> bstr(); }, 1979f11ffb7Safresh1 1989f11ffb7Safresh1 '0+' => sub { $_[0] -> numify(); }, 1999f11ffb7Safresh1 2009f11ffb7Safresh1 '=' => sub { $_[0] -> copy(); }, 2019f11ffb7Safresh1 202b8851fccSafresh1 ; 203b8851fccSafresh1 204b8851fccSafresh1############################################################################## 205b8851fccSafresh1# global constants, flags and assorted stuff 206b8851fccSafresh1 207b8851fccSafresh1# the following are public, but their usage is not recommended. Use the 208b8851fccSafresh1# accessor methods instead. 209b8851fccSafresh1 210b8851fccSafresh1# class constants, use Class->constant_name() to access 211b8851fccSafresh1# one of 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common' 212b8851fccSafresh1$round_mode = 'even'; 213b8851fccSafresh1$accuracy = undef; 214b8851fccSafresh1$precision = undef; 215b8851fccSafresh1$div_scale = 40; 216b8851fccSafresh1 217b8851fccSafresh1$upgrade = undef; 218b8851fccSafresh1$downgrade = undef; 219b8851fccSafresh1# the package we are using for our private parts, defaults to: 2209f11ffb7Safresh1# Math::BigInt->config('lib') 221b46d8ef2Safresh1my $LIB = 'Math::BigInt::Calc'; 222b8851fccSafresh1 223b8851fccSafresh1# are NaNs ok? (otherwise it dies when encountering an NaN) set w/ config() 224b8851fccSafresh1$_trap_nan = 0; 225b8851fccSafresh1# the same for infinity 226b8851fccSafresh1$_trap_inf = 0; 227b8851fccSafresh1 228b8851fccSafresh1# constant for easier life 229b8851fccSafresh1my $nan = 'NaN'; 230b8851fccSafresh1 231*3d61058aSafresh1# Has import() been called yet? This variable is needed to make "require" work. 232*3d61058aSafresh1 233*3d61058aSafresh1my $IMPORT = 0; 234b8851fccSafresh1 235b8851fccSafresh1# some digits of accuracy for blog(undef, 10); which we use in blog() for speed 236b8851fccSafresh1my $LOG_10 = 237b8851fccSafresh1 '2.3025850929940456840179914546843642076011014886287729760333279009675726097'; 238b8851fccSafresh1my $LOG_10_A = length($LOG_10)-1; 239b8851fccSafresh1# ditto for log(2) 240b8851fccSafresh1my $LOG_2 = 241b8851fccSafresh1 '0.6931471805599453094172321214581765680755001343602552541206800094933936220'; 242b8851fccSafresh1my $LOG_2_A = length($LOG_2)-1; 243b8851fccSafresh1my $HALF = '0.5'; # made into an object if nec. 244b8851fccSafresh1 245b8851fccSafresh1############################################################################## 246b8851fccSafresh1# the old code had $rnd_mode, so we need to support it, too 247b8851fccSafresh1 2489f11ffb7Safresh1sub TIESCALAR { 2499f11ffb7Safresh1 my ($class) = @_; 2509f11ffb7Safresh1 bless \$round_mode, $class; 2519f11ffb7Safresh1} 252b8851fccSafresh1 2539f11ffb7Safresh1sub FETCH { 2549f11ffb7Safresh1 return $round_mode; 2559f11ffb7Safresh1} 2569f11ffb7Safresh1 2579f11ffb7Safresh1sub STORE { 258*3d61058aSafresh1 $rnd_mode = (ref $_[0]) -> round_mode($_[1]); 2599f11ffb7Safresh1} 2609f11ffb7Safresh1 2619f11ffb7Safresh1BEGIN { 262*3d61058aSafresh1 *objectify = \&Math::BigInt::objectify; 263*3d61058aSafresh1 264b8851fccSafresh1 # when someone sets $rnd_mode, we catch this and check the value to see 265b8851fccSafresh1 # whether it is valid or not. 2669f11ffb7Safresh1 $rnd_mode = 'even'; 2679f11ffb7Safresh1 tie $rnd_mode, 'Math::BigFloat'; 268b8851fccSafresh1 269e0680481Safresh1 *as_number = \&as_int; 270b8851fccSafresh1} 271b8851fccSafresh1 2729f11ffb7Safresh1sub DESTROY { 2739f11ffb7Safresh1 # going through AUTOLOAD for every DESTROY is costly, avoid it by empty sub 2749f11ffb7Safresh1} 2759f11ffb7Safresh1 2769f11ffb7Safresh1sub AUTOLOAD { 277*3d61058aSafresh1 278*3d61058aSafresh1 # Make fxxx() work by mapping fxxx() to Math::BigFloat::bxxx(). 279*3d61058aSafresh1 2809f11ffb7Safresh1 my $name = $AUTOLOAD; 281*3d61058aSafresh1 $name =~ s/^(.*):://; # strip package name 282*3d61058aSafresh1 my $class = $1 || __PACKAGE__; 283*3d61058aSafresh1 284*3d61058aSafresh1 $class -> import() if $IMPORT == 0; 285*3d61058aSafresh1 286*3d61058aSafresh1 # E.g., "fabs" -> "babs", but "is_neg" -> "is_neg" 287*3d61058aSafresh1 2889f11ffb7Safresh1 my $bname = $name; 2899f11ffb7Safresh1 $bname =~ s/^f/b/; 290*3d61058aSafresh1 291*3d61058aSafresh1 # Map, e.g., Math::BigFloat::fabs() to Math::BigFloat::babs() 292*3d61058aSafresh1 293*3d61058aSafresh1 if ($bname ne $name && Math::BigFloat -> can($bname)) { 294*3d61058aSafresh1 no strict 'refs'; 295*3d61058aSafresh1 return &{"Math::BigFloat::$bname"}(@_); 296*3d61058aSafresh1 } 297*3d61058aSafresh1 298*3d61058aSafresh1 # Map, e.g., Math::BigFloat::babs() to Math::BigInt::babs() 299*3d61058aSafresh1 300*3d61058aSafresh1 elsif (Math::BigInt -> can($bname)) { 301*3d61058aSafresh1 no strict 'refs'; 302*3d61058aSafresh1 return &{"Math::BigInt::$bname"}(@_); 303*3d61058aSafresh1 } 304*3d61058aSafresh1 305*3d61058aSafresh1 else { 306*3d61058aSafresh1 croak("Can't call $class->$name(), not a valid method"); 307*3d61058aSafresh1 } 3089f11ffb7Safresh1} 3099f11ffb7Safresh1 310b8851fccSafresh1############################################################################## 311b8851fccSafresh1 312*3d61058aSafresh1# Compare the following function with @ISA above. This inheritance mess needs a 313*3d61058aSafresh1# clean up. When doing so, also consider the BEGIN block and the AUTOLOAD code. 314*3d61058aSafresh1# Fixme! 315b8851fccSafresh1 3169f11ffb7Safresh1sub isa { 3179f11ffb7Safresh1 my ($self, $class) = @_; 3189f11ffb7Safresh1 return if $class =~ /^Math::BigInt/; # we aren't one of these 3199f11ffb7Safresh1 UNIVERSAL::isa($self, $class); 3209f11ffb7Safresh1} 3219f11ffb7Safresh1 3229f11ffb7Safresh1sub config { 3239f11ffb7Safresh1 # return (later set?) configuration data as hash ref 3249f11ffb7Safresh1 my $class = shift || 'Math::BigFloat'; 3259f11ffb7Safresh1 326b46d8ef2Safresh1 # Getter/accessor. 327b46d8ef2Safresh1 3289f11ffb7Safresh1 if (@_ == 1 && ref($_[0]) ne 'HASH') { 329b46d8ef2Safresh1 my $param = shift; 330b46d8ef2Safresh1 return $class if $param eq 'class'; 331b46d8ef2Safresh1 return $LIB if $param eq 'with'; 332b46d8ef2Safresh1 return $class->SUPER::config($param); 3339f11ffb7Safresh1 } 3349f11ffb7Safresh1 335b46d8ef2Safresh1 # Setter. 336b46d8ef2Safresh1 3379f11ffb7Safresh1 my $cfg = $class->SUPER::config(@_); 3389f11ffb7Safresh1 3399f11ffb7Safresh1 # now we need only to override the ones that are different from our parent 3409f11ffb7Safresh1 $cfg->{class} = $class; 341b46d8ef2Safresh1 $cfg->{with} = $LIB; 3429f11ffb7Safresh1 $cfg; 3439f11ffb7Safresh1} 3449f11ffb7Safresh1 3459f11ffb7Safresh1############################################################################### 3469f11ffb7Safresh1# Constructor methods 3479f11ffb7Safresh1############################################################################### 348b8851fccSafresh1 349b8851fccSafresh1sub new { 350e0680481Safresh1 # Create a new Math::BigFloat object from a string or another bigfloat 351e0680481Safresh1 # object. 352b8851fccSafresh1 # _e: exponent 353b8851fccSafresh1 # _m: mantissa 3549f11ffb7Safresh1 # sign => ("+", "-", "+inf", "-inf", or "NaN") 355b8851fccSafresh1 356b8851fccSafresh1 my $self = shift; 357b8851fccSafresh1 my $selfref = ref $self; 358b8851fccSafresh1 my $class = $selfref || $self; 359b8851fccSafresh1 360eac174f2Safresh1 # Make "require" work. 361eac174f2Safresh1 362eac174f2Safresh1 $class -> import() if $IMPORT == 0; 363eac174f2Safresh1 364eac174f2Safresh1 # Although this use has been discouraged for more than 10 years, people 365eac174f2Safresh1 # apparently still use it, so we still support it. 366eac174f2Safresh1 367eac174f2Safresh1 return $class -> bzero() unless @_; 368eac174f2Safresh1 369b8851fccSafresh1 my ($wanted, @r) = @_; 370b8851fccSafresh1 371eac174f2Safresh1 if (!defined($wanted)) { 372eac174f2Safresh1 #if (warnings::enabled("uninitialized")) { 373eac174f2Safresh1 # warnings::warn("uninitialized", 374eac174f2Safresh1 # "Use of uninitialized value in new()"); 375eac174f2Safresh1 #} 376eac174f2Safresh1 return $class -> bzero(@r); 377b8851fccSafresh1 } 378b8851fccSafresh1 379eac174f2Safresh1 if (!ref($wanted) && $wanted eq "") { 380eac174f2Safresh1 #if (warnings::enabled("numeric")) { 381eac174f2Safresh1 # warnings::warn("numeric", 382eac174f2Safresh1 # q|Argument "" isn't numeric in new()|); 383eac174f2Safresh1 #} 384eac174f2Safresh1 #return $class -> bzero(@r); 385eac174f2Safresh1 return $class -> bnan(@r); 386b8851fccSafresh1 } 387b8851fccSafresh1 388eac174f2Safresh1 # Initialize a new object. 389b8851fccSafresh1 390b8851fccSafresh1 $self = bless {}, $class unless $selfref; 391b8851fccSafresh1 392e0680481Safresh1 # Math::BigFloat or subclass 393eac174f2Safresh1 394*3d61058aSafresh1 if (defined(blessed($wanted)) && $wanted -> isa(__PACKAGE__)) { 395e0680481Safresh1 396e0680481Safresh1 # Don't copy the accuracy and precision, because a new object should get 397e0680481Safresh1 # them from the global configuration. 398e0680481Safresh1 399eac174f2Safresh1 $self -> {sign} = $wanted -> {sign}; 400eac174f2Safresh1 $self -> {_m} = $LIB -> _copy($wanted -> {_m}); 401eac174f2Safresh1 $self -> {_es} = $wanted -> {_es}; 402eac174f2Safresh1 $self -> {_e} = $LIB -> _copy($wanted -> {_e}); 403e0680481Safresh1 $self = $self->round(@r) 404e0680481Safresh1 unless @r >= 2 && !defined($r[0]) && !defined($r[1]); 405eac174f2Safresh1 return $self; 406eac174f2Safresh1 } 407eac174f2Safresh1 408eac174f2Safresh1 # Shortcut for Math::BigInt and its subclasses. This should be improved. 409eac174f2Safresh1 410eac174f2Safresh1 if (defined(blessed($wanted))) { 411eac174f2Safresh1 if ($wanted -> isa('Math::BigInt')) { 412eac174f2Safresh1 $self->{sign} = $wanted -> {sign}; 413eac174f2Safresh1 $self->{_m} = $LIB -> _copy($wanted -> {value}); 414b8851fccSafresh1 $self->{_es} = '+'; 415eac174f2Safresh1 $self->{_e} = $LIB -> _zero(); 416b8851fccSafresh1 return $self -> bnorm(); 417b8851fccSafresh1 } 418b8851fccSafresh1 419eac174f2Safresh1 if ($wanted -> can("as_number")) { 420eac174f2Safresh1 $self->{sign} = $wanted -> sign(); 421eac174f2Safresh1 $self->{_m} = $wanted -> as_number() -> {value}; 422eac174f2Safresh1 $self->{_es} = '+'; 423eac174f2Safresh1 $self->{_e} = $LIB -> _zero(); 424eac174f2Safresh1 return $self -> bnorm(); 425eac174f2Safresh1 } 426eac174f2Safresh1 } 427b8851fccSafresh1 428e0680481Safresh1 # Shortcut for simple forms like '123' that have no trailing zeros. Trailing 429e0680481Safresh1 # zeros would require a non-zero exponent. 430b8851fccSafresh1 431e0680481Safresh1 if ($wanted =~ 432e0680481Safresh1 / ^ 433eac174f2Safresh1 \s* # optional leading whitespace 434eac174f2Safresh1 ( [+-]? ) # optional sign 435eac174f2Safresh1 0* # optional leading zeros 436eac174f2Safresh1 ( [1-9] (?: [0-9]* [1-9] )? ) # significand 437eac174f2Safresh1 \s* # optional trailing whitespace 43856d68f1eSafresh1 $ 43956d68f1eSafresh1 /x) 44056d68f1eSafresh1 { 441eac174f2Safresh1 return $downgrade -> new($1 . $2) if defined $downgrade; 442b8851fccSafresh1 $self->{sign} = $1 || '+'; 443b46d8ef2Safresh1 $self->{_m} = $LIB -> _new($2); 444b8851fccSafresh1 $self->{_es} = '+'; 445eac174f2Safresh1 $self->{_e} = $LIB -> _zero(); 446e0680481Safresh1 $self = $self->round(@r) 447e0680481Safresh1 unless @r >= 2 && !defined $r[0] && !defined $r[1]; 4489f11ffb7Safresh1 return $self; 449b8851fccSafresh1 } 450eac174f2Safresh1 451e0680481Safresh1 # Handle Infs. 452e0680481Safresh1 453e0680481Safresh1 if ($wanted =~ / ^ 454e0680481Safresh1 \s* 455e0680481Safresh1 ( [+-]? ) 456e0680481Safresh1 inf (?: inity )? 457e0680481Safresh1 \s* 458e0680481Safresh1 \z 459e0680481Safresh1 /ix) 460e0680481Safresh1 { 461e0680481Safresh1 my $sgn = $1 || '+'; 462e0680481Safresh1 return $class -> binf($sgn, @r); 463e0680481Safresh1 } 464e0680481Safresh1 465e0680481Safresh1 # Handle explicit NaNs (not the ones returned due to invalid input). 466e0680481Safresh1 467e0680481Safresh1 if ($wanted =~ / ^ 468e0680481Safresh1 \s* 469e0680481Safresh1 ( [+-]? ) 470e0680481Safresh1 nan 471e0680481Safresh1 \s* 472e0680481Safresh1 \z 473e0680481Safresh1 /ix) 474e0680481Safresh1 { 475e0680481Safresh1 return $class -> bnan(@r); 476e0680481Safresh1 } 477e0680481Safresh1 478eac174f2Safresh1 my @parts; 479eac174f2Safresh1 480eac174f2Safresh1 if ( 481eac174f2Safresh1 # Handle hexadecimal numbers. We auto-detect hexadecimal numbers if they 482eac174f2Safresh1 # have a "0x", "0X", "x", or "X" prefix, cf. CORE::oct(). 483eac174f2Safresh1 484eac174f2Safresh1 $wanted =~ /^\s*[+-]?0?[Xx]/ and 485e0680481Safresh1 @parts = $class -> _hex_str_to_flt_lib_parts($wanted) 486eac174f2Safresh1 487eac174f2Safresh1 or 488eac174f2Safresh1 489eac174f2Safresh1 # Handle octal numbers. We auto-detect octal numbers if they have a 490eac174f2Safresh1 # "0o", "0O", "o", "O" prefix, cf. CORE::oct(). 491eac174f2Safresh1 492eac174f2Safresh1 $wanted =~ /^\s*[+-]?0?[Oo]/ and 493e0680481Safresh1 @parts = $class -> _oct_str_to_flt_lib_parts($wanted) 494eac174f2Safresh1 495eac174f2Safresh1 or 496eac174f2Safresh1 497eac174f2Safresh1 # Handle binary numbers. We auto-detect binary numbers if they have a 498eac174f2Safresh1 # "0b", "0B", "b", or "B" prefix, cf. CORE::oct(). 499eac174f2Safresh1 500eac174f2Safresh1 $wanted =~ /^\s*[+-]?0?[Bb]/ and 501e0680481Safresh1 @parts = $class -> _bin_str_to_flt_lib_parts($wanted) 502eac174f2Safresh1 503eac174f2Safresh1 or 504eac174f2Safresh1 505eac174f2Safresh1 # At this point, what is left are decimal numbers that aren't handled 506eac174f2Safresh1 # above and octal floating point numbers that don't have any of the 507eac174f2Safresh1 # "0o", "0O", "o", or "O" prefixes. First see if it is a decimal number. 508eac174f2Safresh1 509e0680481Safresh1 @parts = $class -> _dec_str_to_flt_lib_parts($wanted) 510eac174f2Safresh1 or 511eac174f2Safresh1 512eac174f2Safresh1 # See if it is an octal floating point number. The extra check is 513e0680481Safresh1 # included because _oct_str_to_flt_lib_parts() accepts octal numbers 514e0680481Safresh1 # that don't have a prefix (this is needed to make it work with, e.g., 515eac174f2Safresh1 # from_oct() that don't require a prefix). However, Perl requires a 516eac174f2Safresh1 # prefix for octal floating point literals. For example, "1p+0" is not 517eac174f2Safresh1 # valid, but "01p+0" and "0__1p+0" are. 518eac174f2Safresh1 519eac174f2Safresh1 $wanted =~ /^\s*[+-]?0_*\d/ and 520e0680481Safresh1 @parts = $class -> _oct_str_to_flt_lib_parts($wanted)) 521eac174f2Safresh1 { 522eac174f2Safresh1 ($self->{sign}, $self->{_m}, $self->{_es}, $self->{_e}) = @parts; 523e0680481Safresh1 524e0680481Safresh1 $self = $self->round(@r) 525e0680481Safresh1 unless @r >= 2 && !defined($r[0]) && !defined($r[1]); 526e0680481Safresh1 527e0680481Safresh1 return $downgrade -> new($self -> bdstr(), @r) 528e0680481Safresh1 if defined($downgrade) && $self -> is_int(); 5299f11ffb7Safresh1 return $self; 5309f11ffb7Safresh1 } 5319f11ffb7Safresh1 532eac174f2Safresh1 # If we get here, the value is neither a valid decimal, binary, octal, or 533eac174f2Safresh1 # hexadecimal number. It is not an explicit Inf or a NaN either. 534eac174f2Safresh1 535e0680481Safresh1 return $class -> bnan(@r); 536eac174f2Safresh1} 537eac174f2Safresh1 538eac174f2Safresh1sub from_dec { 539eac174f2Safresh1 my $self = shift; 540eac174f2Safresh1 my $selfref = ref $self; 541eac174f2Safresh1 my $class = $selfref || $self; 542eac174f2Safresh1 543*3d61058aSafresh1 # Make "require" work. 544*3d61058aSafresh1 545*3d61058aSafresh1 $class -> import() if $IMPORT == 0; 546*3d61058aSafresh1 547eac174f2Safresh1 # Don't modify constant (read-only) objects. 548eac174f2Safresh1 549e0680481Safresh1 return $self if $selfref && $self->modify('from_dec'); 550eac174f2Safresh1 551eac174f2Safresh1 my $str = shift; 552eac174f2Safresh1 my @r = @_; 553eac174f2Safresh1 554eac174f2Safresh1 # If called as a class method, initialize a new object. 555eac174f2Safresh1 556e0680481Safresh1 $self = bless {}, $class unless $selfref; 557eac174f2Safresh1 558e0680481Safresh1 if (my @parts = $class -> _dec_str_to_flt_lib_parts($str)) { 559eac174f2Safresh1 ($self->{sign}, $self->{_m}, $self->{_es}, $self->{_e}) = @parts; 560e0680481Safresh1 561e0680481Safresh1 $self = $self->round(@r) 562e0680481Safresh1 unless @r >= 2 && !defined($r[0]) && !defined($r[1]); 563e0680481Safresh1 564e0680481Safresh1 return $downgrade -> new($self -> bdstr(), @r) 565e0680481Safresh1 if defined($downgrade) && $self -> is_int(); 566eac174f2Safresh1 return $self; 567eac174f2Safresh1 } 568eac174f2Safresh1 569eac174f2Safresh1 return $self -> bnan(@r); 570eac174f2Safresh1} 571eac174f2Safresh1 5729f11ffb7Safresh1sub from_hex { 5739f11ffb7Safresh1 my $self = shift; 5749f11ffb7Safresh1 my $selfref = ref $self; 5759f11ffb7Safresh1 my $class = $selfref || $self; 5769f11ffb7Safresh1 577*3d61058aSafresh1 # Make "require" work. 578*3d61058aSafresh1 579*3d61058aSafresh1 $class -> import() if $IMPORT == 0; 580*3d61058aSafresh1 5819f11ffb7Safresh1 # Don't modify constant (read-only) objects. 5829f11ffb7Safresh1 583e0680481Safresh1 return $self if $selfref && $self->modify('from_hex'); 5849f11ffb7Safresh1 5859f11ffb7Safresh1 my $str = shift; 586eac174f2Safresh1 my @r = @_; 5879f11ffb7Safresh1 5889f11ffb7Safresh1 # If called as a class method, initialize a new object. 5899f11ffb7Safresh1 590e0680481Safresh1 $self = bless {}, $class unless $selfref; 5919f11ffb7Safresh1 592e0680481Safresh1 if (my @parts = $class -> _hex_str_to_flt_lib_parts($str)) { 593eac174f2Safresh1 ($self->{sign}, $self->{_m}, $self->{_es}, $self->{_e}) = @parts; 594e0680481Safresh1 595e0680481Safresh1 $self = $self->round(@r) 596e0680481Safresh1 unless @r >= 2 && !defined($r[0]) && !defined($r[1]); 597e0680481Safresh1 598e0680481Safresh1 return $downgrade -> new($self -> bdstr(), @r) 599e0680481Safresh1 if defined($downgrade) && $self -> is_int(); 6009f11ffb7Safresh1 return $self; 6019f11ffb7Safresh1 } 6029f11ffb7Safresh1 603eac174f2Safresh1 return $self -> bnan(@r); 6049f11ffb7Safresh1} 6059f11ffb7Safresh1 6069f11ffb7Safresh1sub from_oct { 6079f11ffb7Safresh1 my $self = shift; 6089f11ffb7Safresh1 my $selfref = ref $self; 6099f11ffb7Safresh1 my $class = $selfref || $self; 6109f11ffb7Safresh1 611*3d61058aSafresh1 # Make "require" work. 612*3d61058aSafresh1 613*3d61058aSafresh1 $class -> import() if $IMPORT == 0; 614*3d61058aSafresh1 6159f11ffb7Safresh1 # Don't modify constant (read-only) objects. 6169f11ffb7Safresh1 617e0680481Safresh1 return $self if $selfref && $self->modify('from_oct'); 6189f11ffb7Safresh1 6199f11ffb7Safresh1 my $str = shift; 620eac174f2Safresh1 my @r = @_; 6219f11ffb7Safresh1 6229f11ffb7Safresh1 # If called as a class method, initialize a new object. 6239f11ffb7Safresh1 624e0680481Safresh1 $self = bless {}, $class unless $selfref; 6259f11ffb7Safresh1 626e0680481Safresh1 if (my @parts = $class -> _oct_str_to_flt_lib_parts($str)) { 627eac174f2Safresh1 ($self->{sign}, $self->{_m}, $self->{_es}, $self->{_e}) = @parts; 628e0680481Safresh1 629e0680481Safresh1 $self = $self->round(@r) 630e0680481Safresh1 unless @r >= 2 && !defined($r[0]) && !defined($r[1]); 631e0680481Safresh1 632e0680481Safresh1 return $downgrade -> new($self -> bdstr(), @r) 633e0680481Safresh1 if defined($downgrade) && $self -> is_int(); 6349f11ffb7Safresh1 return $self; 6359f11ffb7Safresh1 } 6369f11ffb7Safresh1 637eac174f2Safresh1 return $self -> bnan(@r); 6389f11ffb7Safresh1} 6399f11ffb7Safresh1 6409f11ffb7Safresh1sub from_bin { 6419f11ffb7Safresh1 my $self = shift; 6429f11ffb7Safresh1 my $selfref = ref $self; 6439f11ffb7Safresh1 my $class = $selfref || $self; 6449f11ffb7Safresh1 645*3d61058aSafresh1 # Make "require" work. 646*3d61058aSafresh1 647*3d61058aSafresh1 $class -> import() if $IMPORT == 0; 648*3d61058aSafresh1 6499f11ffb7Safresh1 # Don't modify constant (read-only) objects. 6509f11ffb7Safresh1 651e0680481Safresh1 return $self if $selfref && $self->modify('from_bin'); 6529f11ffb7Safresh1 6539f11ffb7Safresh1 my $str = shift; 654eac174f2Safresh1 my @r = @_; 6559f11ffb7Safresh1 6569f11ffb7Safresh1 # If called as a class method, initialize a new object. 6579f11ffb7Safresh1 658e0680481Safresh1 $self = bless {}, $class unless $selfref; 6599f11ffb7Safresh1 660e0680481Safresh1 if (my @parts = $class -> _bin_str_to_flt_lib_parts($str)) { 661eac174f2Safresh1 ($self->{sign}, $self->{_m}, $self->{_es}, $self->{_e}) = @parts; 662e0680481Safresh1 663e0680481Safresh1 $self = $self->round(@r) 664e0680481Safresh1 unless @r >= 2 && !defined($r[0]) && !defined($r[1]); 665e0680481Safresh1 666e0680481Safresh1 return $downgrade -> new($self -> bdstr(), @r) 667e0680481Safresh1 if defined($downgrade) && $self -> is_int(); 6689f11ffb7Safresh1 return $self; 6699f11ffb7Safresh1 } 6709f11ffb7Safresh1 671eac174f2Safresh1 return $self -> bnan(@r); 6729f11ffb7Safresh1} 6739f11ffb7Safresh1 67456d68f1eSafresh1sub from_ieee754 { 67556d68f1eSafresh1 my $self = shift; 67656d68f1eSafresh1 my $selfref = ref $self; 67756d68f1eSafresh1 my $class = $selfref || $self; 67856d68f1eSafresh1 679*3d61058aSafresh1 # Make "require" work. 680*3d61058aSafresh1 681*3d61058aSafresh1 $class -> import() if $IMPORT == 0; 682*3d61058aSafresh1 68356d68f1eSafresh1 # Don't modify constant (read-only) objects. 68456d68f1eSafresh1 685e0680481Safresh1 return $self if $selfref && $self->modify('from_ieee754'); 68656d68f1eSafresh1 68756d68f1eSafresh1 my $in = shift; # input string (or raw bytes) 68856d68f1eSafresh1 my $format = shift; # format ("binary32", "decimal64" etc.) 68956d68f1eSafresh1 my $enc; # significand encoding (applies only to decimal) 69056d68f1eSafresh1 my $k; # storage width in bits 69156d68f1eSafresh1 my $b; # base 692e0680481Safresh1 my @r = @_; # rounding parameters, if any 69356d68f1eSafresh1 69456d68f1eSafresh1 if ($format =~ /^binary(\d+)\z/) { 69556d68f1eSafresh1 $k = $1; 69656d68f1eSafresh1 $b = 2; 69756d68f1eSafresh1 } elsif ($format =~ /^decimal(\d+)(dpd|bcd)?\z/) { 69856d68f1eSafresh1 $k = $1; 69956d68f1eSafresh1 $b = 10; 70056d68f1eSafresh1 $enc = $2 || 'dpd'; # default is dencely-packed decimals (DPD) 70156d68f1eSafresh1 } elsif ($format eq 'half') { 70256d68f1eSafresh1 $k = 16; 70356d68f1eSafresh1 $b = 2; 70456d68f1eSafresh1 } elsif ($format eq 'single') { 70556d68f1eSafresh1 $k = 32; 70656d68f1eSafresh1 $b = 2; 70756d68f1eSafresh1 } elsif ($format eq 'double') { 70856d68f1eSafresh1 $k = 64; 70956d68f1eSafresh1 $b = 2; 71056d68f1eSafresh1 } elsif ($format eq 'quadruple') { 71156d68f1eSafresh1 $k = 128; 71256d68f1eSafresh1 $b = 2; 71356d68f1eSafresh1 } elsif ($format eq 'octuple') { 71456d68f1eSafresh1 $k = 256; 71556d68f1eSafresh1 $b = 2; 71656d68f1eSafresh1 } elsif ($format eq 'sexdecuple') { 71756d68f1eSafresh1 $k = 512; 71856d68f1eSafresh1 $b = 2; 71956d68f1eSafresh1 } 72056d68f1eSafresh1 72156d68f1eSafresh1 if ($b == 2) { 72256d68f1eSafresh1 72356d68f1eSafresh1 # Get the parameters for this format. 72456d68f1eSafresh1 72556d68f1eSafresh1 my $p; # precision (in bits) 72656d68f1eSafresh1 my $t; # number of bits in significand 72756d68f1eSafresh1 my $w; # number of bits in exponent 72856d68f1eSafresh1 72956d68f1eSafresh1 if ($k == 16) { # binary16 (half-precision) 73056d68f1eSafresh1 $p = 11; 73156d68f1eSafresh1 $t = 10; 73256d68f1eSafresh1 $w = 5; 73356d68f1eSafresh1 } elsif ($k == 32) { # binary32 (single-precision) 73456d68f1eSafresh1 $p = 24; 73556d68f1eSafresh1 $t = 23; 73656d68f1eSafresh1 $w = 8; 73756d68f1eSafresh1 } elsif ($k == 64) { # binary64 (double-precision) 73856d68f1eSafresh1 $p = 53; 73956d68f1eSafresh1 $t = 52; 74056d68f1eSafresh1 $w = 11; 74156d68f1eSafresh1 } else { # binaryN (quadruple-precision and above) 74256d68f1eSafresh1 if ($k < 128 || $k != 32 * sprintf('%.0f', $k / 32)) { 74356d68f1eSafresh1 croak "Number of bits must be 16, 32, 64, or >= 128 and", 74456d68f1eSafresh1 " a multiple of 32"; 74556d68f1eSafresh1 } 74656d68f1eSafresh1 $p = $k - sprintf('%.0f', 4 * log($k) / log(2)) + 13; 74756d68f1eSafresh1 $t = $p - 1; 74856d68f1eSafresh1 $w = $k - $t - 1; 74956d68f1eSafresh1 } 75056d68f1eSafresh1 75156d68f1eSafresh1 # The maximum exponent, minimum exponent, and exponent bias. 75256d68f1eSafresh1 753*3d61058aSafresh1 my $emax = $class -> new(2) -> bpow($w - 1) -> bdec(); 75456d68f1eSafresh1 my $emin = 1 - $emax; 75556d68f1eSafresh1 my $bias = $emax; 75656d68f1eSafresh1 75756d68f1eSafresh1 # Undefined input. 75856d68f1eSafresh1 75956d68f1eSafresh1 unless (defined $in) { 76056d68f1eSafresh1 carp("Input is undefined"); 761eac174f2Safresh1 return $self -> bzero(@r); 76256d68f1eSafresh1 } 76356d68f1eSafresh1 76456d68f1eSafresh1 # Make sure input string is a string of zeros and ones. 76556d68f1eSafresh1 76656d68f1eSafresh1 my $len = CORE::length $in; 76756d68f1eSafresh1 if (8 * $len == $k) { # bytes 76856d68f1eSafresh1 $in = unpack "B*", $in; 76956d68f1eSafresh1 } elsif (4 * $len == $k) { # hexadecimal 77056d68f1eSafresh1 if ($in =~ /([^\da-f])/i) { 77156d68f1eSafresh1 croak "Illegal hexadecimal digit '$1'"; 77256d68f1eSafresh1 } 77356d68f1eSafresh1 $in = unpack "B*", pack "H*", $in; 77456d68f1eSafresh1 } elsif ($len == $k) { # bits 77556d68f1eSafresh1 if ($in =~ /([^01])/) { 77656d68f1eSafresh1 croak "Illegal binary digit '$1'"; 77756d68f1eSafresh1 } 77856d68f1eSafresh1 } else { 77956d68f1eSafresh1 croak "Unknown input -- $in"; 78056d68f1eSafresh1 } 78156d68f1eSafresh1 78256d68f1eSafresh1 # Split bit string into sign, exponent, and mantissa/significand. 78356d68f1eSafresh1 78456d68f1eSafresh1 my $sign = substr($in, 0, 1) eq '1' ? '-' : '+'; 78556d68f1eSafresh1 my $expo = $class -> from_bin(substr($in, 1, $w)); 78656d68f1eSafresh1 my $mant = $class -> from_bin(substr($in, $w + 1)); 78756d68f1eSafresh1 78856d68f1eSafresh1 my $x; 78956d68f1eSafresh1 790e0680481Safresh1 $expo = $expo -> bsub($bias); # subtract bias 79156d68f1eSafresh1 79256d68f1eSafresh1 if ($expo < $emin) { # zero and subnormals 79356d68f1eSafresh1 if ($mant == 0) { # zero 79456d68f1eSafresh1 $x = $class -> bzero(); 79556d68f1eSafresh1 } else { # subnormals 79656d68f1eSafresh1 # compute (1/$b)**(N) rather than ($b)**(-N) 79756d68f1eSafresh1 $x = $class -> new("0.5"); # 1/$b 798e0680481Safresh1 $x = $x -> bpow($bias + $t - 1) -> bmul($mant); 799e0680481Safresh1 $x = $x -> bneg() if $sign eq '-'; 80056d68f1eSafresh1 } 80156d68f1eSafresh1 } 80256d68f1eSafresh1 80356d68f1eSafresh1 elsif ($expo > $emax) { # inf and nan 80456d68f1eSafresh1 if ($mant == 0) { # inf 80556d68f1eSafresh1 $x = $class -> binf($sign); 80656d68f1eSafresh1 } else { # nan 807e0680481Safresh1 $x = $class -> bnan(@r); 80856d68f1eSafresh1 } 80956d68f1eSafresh1 } 81056d68f1eSafresh1 81156d68f1eSafresh1 else { # normals 81256d68f1eSafresh1 $mant = $class -> new(2) -> bpow($t) -> badd($mant); 81356d68f1eSafresh1 if ($expo < $t) { 81456d68f1eSafresh1 # compute (1/$b)**(N) rather than ($b)**(-N) 81556d68f1eSafresh1 $x = $class -> new("0.5"); # 1/$b 816e0680481Safresh1 $x = $x -> bpow($t - $expo) -> bmul($mant); 81756d68f1eSafresh1 } else { 81856d68f1eSafresh1 $x = $class -> new(2); 819e0680481Safresh1 $x = $x -> bpow($expo - $t) -> bmul($mant); 82056d68f1eSafresh1 } 821e0680481Safresh1 $x = $x -> bneg() if $sign eq '-'; 82256d68f1eSafresh1 } 82356d68f1eSafresh1 82456d68f1eSafresh1 if ($selfref) { 82556d68f1eSafresh1 $self -> {sign} = $x -> {sign}; 82656d68f1eSafresh1 $self -> {_m} = $x -> {_m}; 82756d68f1eSafresh1 $self -> {_es} = $x -> {_es}; 82856d68f1eSafresh1 $self -> {_e} = $x -> {_e}; 82956d68f1eSafresh1 } else { 83056d68f1eSafresh1 $self = $x; 83156d68f1eSafresh1 } 832eac174f2Safresh1 833e0680481Safresh1 return $downgrade -> new($self -> bdstr(), @r) 834e0680481Safresh1 if defined($downgrade) && $self -> is_int(); 835eac174f2Safresh1 return $self -> round(@r); 83656d68f1eSafresh1 } 83756d68f1eSafresh1 83856d68f1eSafresh1 croak("The format '$format' is not yet supported."); 83956d68f1eSafresh1} 84056d68f1eSafresh1 8419f11ffb7Safresh1sub bzero { 8429f11ffb7Safresh1 # create/assign '+0' 8439f11ffb7Safresh1 844e0680481Safresh1 # Class::method(...) -> Class->method(...) 845e0680481Safresh1 unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || 846e0680481Safresh1 $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) 847e0680481Safresh1 { 848e0680481Safresh1 #carp "Using ", (caller(0))[3], "() as a function is deprecated;", 849e0680481Safresh1 # " use is as a method instead"; 8509f11ffb7Safresh1 unshift @_, __PACKAGE__; 8519f11ffb7Safresh1 } 8529f11ffb7Safresh1 8539f11ffb7Safresh1 my $self = shift; 8549f11ffb7Safresh1 my $selfref = ref $self; 8559f11ffb7Safresh1 my $class = $selfref || $self; 8569f11ffb7Safresh1 857*3d61058aSafresh1 # Make "require" work. 858*3d61058aSafresh1 859*3d61058aSafresh1 $class -> import() if $IMPORT == 0; 8609f11ffb7Safresh1 861e0680481Safresh1 # Don't modify constant (read-only) objects. 862e0680481Safresh1 863e0680481Safresh1 return $self if $selfref && $self->modify('bzero'); 864e0680481Safresh1 865e0680481Safresh1 # Get the rounding parameters, if any. 866e0680481Safresh1 867e0680481Safresh1 my @r = @_; 868e0680481Safresh1 869e0680481Safresh1 return $downgrade -> bzero(@r) if defined $downgrade; 870e0680481Safresh1 871e0680481Safresh1 # If called as a class method, initialize a new object. 872eac174f2Safresh1 8739f11ffb7Safresh1 $self = bless {}, $class unless $selfref; 8749f11ffb7Safresh1 8759f11ffb7Safresh1 $self -> {sign} = '+'; 876b46d8ef2Safresh1 $self -> {_m} = $LIB -> _zero(); 8779f11ffb7Safresh1 $self -> {_es} = '+'; 878b46d8ef2Safresh1 $self -> {_e} = $LIB -> _zero(); 8799f11ffb7Safresh1 880b46d8ef2Safresh1 # If rounding parameters are given as arguments, use them. If no rounding 881b46d8ef2Safresh1 # parameters are given, and if called as a class method initialize the new 882b46d8ef2Safresh1 # instance with the class variables. 883b46d8ef2Safresh1 884e0680481Safresh1 #return $self -> round(@r); # this should work, but doesnt; fixme! 885e0680481Safresh1 886e0680481Safresh1 if (@r) { 887*3d61058aSafresh1 if (@r >= 2 && defined($r[0]) && defined($r[1])) { 888*3d61058aSafresh1 carp "can't specify both accuracy and precision"; 889*3d61058aSafresh1 return $self -> bnan(); 890*3d61058aSafresh1 } 891*3d61058aSafresh1 $self->{accuracy} = $r[0]; 892*3d61058aSafresh1 $self->{precision} = $r[1]; 8939f11ffb7Safresh1 } else { 894b46d8ef2Safresh1 unless($selfref) { 895*3d61058aSafresh1 $self->{accuracy} = $class -> accuracy(); 896*3d61058aSafresh1 $self->{precision} = $class -> precision(); 8979f11ffb7Safresh1 } 8989f11ffb7Safresh1 } 8999f11ffb7Safresh1 9009f11ffb7Safresh1 return $self; 9019f11ffb7Safresh1} 9029f11ffb7Safresh1 9039f11ffb7Safresh1sub bone { 9049f11ffb7Safresh1 # Create or assign '+1' (or -1 if given sign '-'). 9059f11ffb7Safresh1 906e0680481Safresh1 # Class::method(...) -> Class->method(...) 907e0680481Safresh1 unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || 908e0680481Safresh1 $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) 909e0680481Safresh1 { 910e0680481Safresh1 #carp "Using ", (caller(0))[3], "() as a function is deprecated;", 911e0680481Safresh1 # " use is as a method instead"; 9129f11ffb7Safresh1 unshift @_, __PACKAGE__; 9139f11ffb7Safresh1 } 9149f11ffb7Safresh1 9159f11ffb7Safresh1 my $self = shift; 9169f11ffb7Safresh1 my $selfref = ref $self; 9179f11ffb7Safresh1 my $class = $selfref || $self; 9189f11ffb7Safresh1 919*3d61058aSafresh1 # Make "require" work. 920*3d61058aSafresh1 921*3d61058aSafresh1 $class -> import() if $IMPORT == 0; 9229f11ffb7Safresh1 923e0680481Safresh1 # Don't modify constant (read-only) objects. 924eac174f2Safresh1 925e0680481Safresh1 return $self if $selfref && $self->modify('bone'); 926e0680481Safresh1 927e0680481Safresh1 return $downgrade -> bone(@_) if defined $downgrade; 928e0680481Safresh1 929e0680481Safresh1 # Get the sign. 930e0680481Safresh1 931e0680481Safresh1 my $sign = '+'; # default is to return +1 932e0680481Safresh1 if (defined($_[0]) && $_[0] =~ /^\s*([+-])\s*$/) { 933e0680481Safresh1 $sign = $1; 934e0680481Safresh1 shift; 935e0680481Safresh1 } 936e0680481Safresh1 937e0680481Safresh1 # Get the rounding parameters, if any. 938e0680481Safresh1 939e0680481Safresh1 my @r = @_; 940e0680481Safresh1 941e0680481Safresh1 # If called as a class method, initialize a new object. 9429f11ffb7Safresh1 9439f11ffb7Safresh1 $self = bless {}, $class unless $selfref; 9449f11ffb7Safresh1 9459f11ffb7Safresh1 $self -> {sign} = $sign; 946b46d8ef2Safresh1 $self -> {_m} = $LIB -> _one(); 9479f11ffb7Safresh1 $self -> {_es} = '+'; 948b46d8ef2Safresh1 $self -> {_e} = $LIB -> _zero(); 9499f11ffb7Safresh1 950b46d8ef2Safresh1 # If rounding parameters are given as arguments, use them. If no rounding 951b46d8ef2Safresh1 # parameters are given, and if called as a class method initialize the new 952b46d8ef2Safresh1 # instance with the class variables. 953b46d8ef2Safresh1 954e0680481Safresh1 #return $self -> round(@r); # this should work, but doesnt; fixme! 955e0680481Safresh1 956e0680481Safresh1 if (@r) { 957*3d61058aSafresh1 if (@r >= 2 && defined($r[0]) && defined($r[1])) { 958*3d61058aSafresh1 carp "can't specify both accuracy and precision"; 959*3d61058aSafresh1 return $self -> bnan(); 960*3d61058aSafresh1 } 961*3d61058aSafresh1 $self->{accuracy} = $_[0]; 962*3d61058aSafresh1 $self->{precision} = $_[1]; 9639f11ffb7Safresh1 } else { 964b46d8ef2Safresh1 unless($selfref) { 965*3d61058aSafresh1 $self->{accuracy} = $class -> accuracy(); 966*3d61058aSafresh1 $self->{precision} = $class -> precision(); 9679f11ffb7Safresh1 } 9689f11ffb7Safresh1 } 9699f11ffb7Safresh1 9709f11ffb7Safresh1 return $self; 9719f11ffb7Safresh1} 9729f11ffb7Safresh1 9739f11ffb7Safresh1sub binf { 9749f11ffb7Safresh1 # create/assign a '+inf' or '-inf' 9759f11ffb7Safresh1 976e0680481Safresh1 # Class::method(...) -> Class->method(...) 977e0680481Safresh1 unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || 978e0680481Safresh1 $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) 9799f11ffb7Safresh1 { 980e0680481Safresh1 #carp "Using ", (caller(0))[3], "() as a function is deprecated;", 981e0680481Safresh1 # " use is as a method instead"; 9829f11ffb7Safresh1 unshift @_, __PACKAGE__; 9839f11ffb7Safresh1 } 9849f11ffb7Safresh1 9859f11ffb7Safresh1 my $self = shift; 9869f11ffb7Safresh1 my $selfref = ref $self; 9879f11ffb7Safresh1 my $class = $selfref || $self; 9889f11ffb7Safresh1 9899f11ffb7Safresh1 { 9909f11ffb7Safresh1 no strict 'refs'; 9919f11ffb7Safresh1 if (${"${class}::_trap_inf"}) { 992b46d8ef2Safresh1 croak("Tried to create +-inf in $class->binf()"); 9939f11ffb7Safresh1 } 9949f11ffb7Safresh1 } 9959f11ffb7Safresh1 996*3d61058aSafresh1 # Make "require" work. 997*3d61058aSafresh1 998*3d61058aSafresh1 $class -> import() if $IMPORT == 0; 9999f11ffb7Safresh1 1000e0680481Safresh1 # Don't modify constant (read-only) objects. 1001e0680481Safresh1 1002e0680481Safresh1 return $self if $selfref && $self->modify('binf'); 1003e0680481Safresh1 1004e0680481Safresh1 return $downgrade -> binf(@_) if $downgrade; 1005e0680481Safresh1 1006e0680481Safresh1 # Get the sign. 1007e0680481Safresh1 1008e0680481Safresh1 my $sign = '+'; # default is to return positive infinity 1009e0680481Safresh1 if (defined($_[0]) && $_[0] =~ /^\s*([+-])(inf|$)/i) { 1010e0680481Safresh1 $sign = $1; 1011e0680481Safresh1 shift; 1012e0680481Safresh1 } 1013e0680481Safresh1 1014e0680481Safresh1 # Get the rounding parameters, if any. 1015e0680481Safresh1 1016e0680481Safresh1 my @r = @_; 1017e0680481Safresh1 1018e0680481Safresh1 # If called as a class method, initialize a new object. 10199f11ffb7Safresh1 10209f11ffb7Safresh1 $self = bless {}, $class unless $selfref; 10219f11ffb7Safresh1 10229f11ffb7Safresh1 $self -> {sign} = $sign . 'inf'; 1023b46d8ef2Safresh1 $self -> {_m} = $LIB -> _zero(); 10249f11ffb7Safresh1 $self -> {_es} = '+'; 1025b46d8ef2Safresh1 $self -> {_e} = $LIB -> _zero(); 1026b46d8ef2Safresh1 1027b46d8ef2Safresh1 # If rounding parameters are given as arguments, use them. If no rounding 1028b46d8ef2Safresh1 # parameters are given, and if called as a class method initialize the new 1029b46d8ef2Safresh1 # instance with the class variables. 1030b46d8ef2Safresh1 1031e0680481Safresh1 #return $self -> round(@r); # this should work, but doesnt; fixme! 1032e0680481Safresh1 1033e0680481Safresh1 if (@r) { 1034*3d61058aSafresh1 if (@r >= 2 && defined($r[0]) && defined($r[1])) { 1035*3d61058aSafresh1 carp "can't specify both accuracy and precision"; 1036*3d61058aSafresh1 return $self -> bnan(); 1037*3d61058aSafresh1 } 1038*3d61058aSafresh1 $self->{accuracy} = $r[0]; 1039*3d61058aSafresh1 $self->{precision} = $r[1]; 1040b46d8ef2Safresh1 } else { 1041b46d8ef2Safresh1 unless($selfref) { 1042*3d61058aSafresh1 $self->{accuracy} = $class -> accuracy(); 1043*3d61058aSafresh1 $self->{precision} = $class -> precision(); 1044b46d8ef2Safresh1 } 1045b46d8ef2Safresh1 } 10469f11ffb7Safresh1 10479f11ffb7Safresh1 return $self; 10489f11ffb7Safresh1} 10499f11ffb7Safresh1 10509f11ffb7Safresh1sub bnan { 10519f11ffb7Safresh1 # create/assign a 'NaN' 10529f11ffb7Safresh1 1053e0680481Safresh1 # Class::method(...) -> Class->method(...) 1054e0680481Safresh1 unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || 1055e0680481Safresh1 $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) 1056e0680481Safresh1 { 1057e0680481Safresh1 #carp "Using ", (caller(0))[3], "() as a function is deprecated;", 1058e0680481Safresh1 # " use is as a method instead"; 10599f11ffb7Safresh1 unshift @_, __PACKAGE__; 10609f11ffb7Safresh1 } 10619f11ffb7Safresh1 10629f11ffb7Safresh1 my $self = shift; 10639f11ffb7Safresh1 my $selfref = ref $self; 10649f11ffb7Safresh1 my $class = $selfref || $self; 10659f11ffb7Safresh1 10669f11ffb7Safresh1 { 10679f11ffb7Safresh1 no strict 'refs'; 10689f11ffb7Safresh1 if (${"${class}::_trap_nan"}) { 1069b46d8ef2Safresh1 croak("Tried to create NaN in $class->bnan()"); 10709f11ffb7Safresh1 } 10719f11ffb7Safresh1 } 10729f11ffb7Safresh1 1073*3d61058aSafresh1 # Make "require" work. 1074*3d61058aSafresh1 1075*3d61058aSafresh1 $class -> import() if $IMPORT == 0; 1076e0680481Safresh1 1077e0680481Safresh1 # Don't modify constant (read-only) objects. 1078e0680481Safresh1 1079e0680481Safresh1 return $self if $selfref && $self->modify('bnan'); 1080e0680481Safresh1 1081e0680481Safresh1 return $downgrade -> bnan(@_) if defined $downgrade; 1082e0680481Safresh1 1083e0680481Safresh1 # Get the rounding parameters, if any. 1084e0680481Safresh1 1085e0680481Safresh1 my @r = @_; 1086e0680481Safresh1 1087e0680481Safresh1 # If called as a class method, initialize a new object. 10889f11ffb7Safresh1 10899f11ffb7Safresh1 $self = bless {}, $class unless $selfref; 10909f11ffb7Safresh1 10919f11ffb7Safresh1 $self -> {sign} = $nan; 1092b46d8ef2Safresh1 $self -> {_m} = $LIB -> _zero(); 10939f11ffb7Safresh1 $self -> {_es} = '+'; 1094b46d8ef2Safresh1 $self -> {_e} = $LIB -> _zero(); 1095b46d8ef2Safresh1 1096b46d8ef2Safresh1 # If rounding parameters are given as arguments, use them. If no rounding 1097b46d8ef2Safresh1 # parameters are given, and if called as a class method initialize the new 1098b46d8ef2Safresh1 # instance with the class variables. 1099b46d8ef2Safresh1 1100e0680481Safresh1 #return $self -> round(@r); # this should work, but doesnt; fixme! 1101e0680481Safresh1 1102e0680481Safresh1 if (@r) { 1103*3d61058aSafresh1 if (@r >= 2 && defined($r[0]) && defined($r[1])) { 1104*3d61058aSafresh1 carp "can't specify both accuracy and precision"; 1105*3d61058aSafresh1 return $self -> bnan(); 1106*3d61058aSafresh1 } 1107*3d61058aSafresh1 $self->{accuracy} = $r[0]; 1108*3d61058aSafresh1 $self->{precision} = $r[1]; 1109b46d8ef2Safresh1 } else { 1110b46d8ef2Safresh1 unless($selfref) { 1111*3d61058aSafresh1 $self->{accuracy} = $class -> accuracy(); 1112*3d61058aSafresh1 $self->{precision} = $class -> precision(); 1113b46d8ef2Safresh1 } 1114b46d8ef2Safresh1 } 11159f11ffb7Safresh1 11169f11ffb7Safresh1 return $self; 11179f11ffb7Safresh1} 11189f11ffb7Safresh1 11199f11ffb7Safresh1sub bpi { 11209f11ffb7Safresh1 1121e0680481Safresh1 # Class::method(...) -> Class->method(...) 1122e0680481Safresh1 unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || 1123e0680481Safresh1 $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) 1124e0680481Safresh1 { 1125e0680481Safresh1 #carp "Using ", (caller(0))[3], "() as a function is deprecated;", 1126e0680481Safresh1 # " use is as a method instead"; 1127e0680481Safresh1 unshift @_, __PACKAGE__; 1128e0680481Safresh1 } 1129e0680481Safresh1 11309f11ffb7Safresh1 # Called as Argument list 11319f11ffb7Safresh1 # --------- ------------- 11329f11ffb7Safresh1 # Math::BigFloat->bpi() ("Math::BigFloat") 11339f11ffb7Safresh1 # Math::BigFloat->bpi(10) ("Math::BigFloat", 10) 11349f11ffb7Safresh1 # $x->bpi() ($x) 11359f11ffb7Safresh1 # $x->bpi(10) ($x, 10) 11369f11ffb7Safresh1 # Math::BigFloat::bpi() () 11379f11ffb7Safresh1 # Math::BigFloat::bpi(10) (10) 11389f11ffb7Safresh1 # 11399f11ffb7Safresh1 # In ambiguous cases, we favour the OO-style, so the following case 11409f11ffb7Safresh1 # 11419f11ffb7Safresh1 # $n = Math::BigFloat->new("10"); 11429f11ffb7Safresh1 # $x = Math::BigFloat->bpi($n); 11439f11ffb7Safresh1 # 11449f11ffb7Safresh1 # which gives an argument list with the single element $n, is resolved as 11459f11ffb7Safresh1 # 11469f11ffb7Safresh1 # $n->bpi(); 11479f11ffb7Safresh1 11489f11ffb7Safresh1 my $self = shift; 11499f11ffb7Safresh1 my $selfref = ref $self; 11509f11ffb7Safresh1 my $class = $selfref || $self; 1151e0680481Safresh1 my @r = @_; # rounding paramters 11529f11ffb7Safresh1 1153*3d61058aSafresh1 # Make "require" work. 1154*3d61058aSafresh1 1155*3d61058aSafresh1 $class -> import() if $IMPORT == 0; 1156*3d61058aSafresh1 1157e0680481Safresh1 if ($selfref) { # bpi() called as an instance method 11589f11ffb7Safresh1 return $self if $self -> modify('bpi'); 1159e0680481Safresh1 } else { # bpi() called as a class method 1160e0680481Safresh1 $self = bless {}, $class; # initialize new instance 11619f11ffb7Safresh1 } 11629f11ffb7Safresh1 11639f11ffb7Safresh1 ($self, @r) = $self -> _find_round_parameters(@r); 11649f11ffb7Safresh1 11659f11ffb7Safresh1 # The accuracy, i.e., the number of digits. Pi has one digit before the 11669f11ffb7Safresh1 # dot, so a precision of 4 digits is equivalent to an accuracy of 5 digits. 11679f11ffb7Safresh1 11689f11ffb7Safresh1 my $n = defined $r[0] ? $r[0] 11699f11ffb7Safresh1 : defined $r[1] ? 1 - $r[1] 11709f11ffb7Safresh1 : $self -> div_scale(); 11719f11ffb7Safresh1 11729f11ffb7Safresh1 my $rmode = defined $r[2] ? $r[2] : $self -> round_mode(); 11739f11ffb7Safresh1 11749f11ffb7Safresh1 my $pi; 11759f11ffb7Safresh1 11769f11ffb7Safresh1 if ($n <= 1000) { 11779f11ffb7Safresh1 11789f11ffb7Safresh1 # 75 x 14 = 1050 digits 11799f11ffb7Safresh1 11809f11ffb7Safresh1 my $all_digits = <<EOF; 11819f11ffb7Safresh1314159265358979323846264338327950288419716939937510582097494459230781640628 11829f11ffb7Safresh1620899862803482534211706798214808651328230664709384460955058223172535940812 11839f11ffb7Safresh1848111745028410270193852110555964462294895493038196442881097566593344612847 11849f11ffb7Safresh1564823378678316527120190914564856692346034861045432664821339360726024914127 11859f11ffb7Safresh1372458700660631558817488152092096282925409171536436789259036001133053054882 11869f11ffb7Safresh1046652138414695194151160943305727036575959195309218611738193261179310511854 11879f11ffb7Safresh1807446237996274956735188575272489122793818301194912983367336244065664308602 11889f11ffb7Safresh1139494639522473719070217986094370277053921717629317675238467481846766940513 11899f11ffb7Safresh1200056812714526356082778577134275778960917363717872146844090122495343014654 11909f11ffb7Safresh1958537105079227968925892354201995611212902196086403441815981362977477130996 11919f11ffb7Safresh1051870721134999999837297804995105973173281609631859502445945534690830264252 11929f11ffb7Safresh1230825334468503526193118817101000313783875288658753320838142061717766914730 11939f11ffb7Safresh1359825349042875546873115956286388235378759375195778185778053217122680661300 11949f11ffb7Safresh1192787661119590921642019893809525720106548586327886593615338182796823030195 11959f11ffb7Safresh1EOF 11969f11ffb7Safresh1 11979f11ffb7Safresh1 # Should we round up? 11989f11ffb7Safresh1 11999f11ffb7Safresh1 my $round_up; 12009f11ffb7Safresh1 12019f11ffb7Safresh1 # From the string above, we need to extract the number of digits we 12029f11ffb7Safresh1 # want plus extra characters for the newlines. 12039f11ffb7Safresh1 12049f11ffb7Safresh1 my $nchrs = $n + int($n / 75); 12059f11ffb7Safresh1 12069f11ffb7Safresh1 # Extract the digits we want. 12079f11ffb7Safresh1 12089f11ffb7Safresh1 my $digits = substr($all_digits, 0, $nchrs); 12099f11ffb7Safresh1 1210b46d8ef2Safresh1 # Find out whether we should round up or down. Rounding is easy, since 1211b46d8ef2Safresh1 # pi is trancendental. With directed rounding, it doesn't matter what 1212b46d8ef2Safresh1 # the following digits are. With rounding to nearest, we only have to 1213b46d8ef2Safresh1 # look at one extra digit. 12149f11ffb7Safresh1 1215b46d8ef2Safresh1 if ($rmode eq 'trunc') { 12169f11ffb7Safresh1 $round_up = 0; 12179f11ffb7Safresh1 } else { 12189f11ffb7Safresh1 my $next_digit = substr($all_digits, $nchrs, 1); 12199f11ffb7Safresh1 $round_up = $next_digit lt '5' ? 0 : 1; 12209f11ffb7Safresh1 } 12219f11ffb7Safresh1 12229f11ffb7Safresh1 # Remove the newlines. 12239f11ffb7Safresh1 12249f11ffb7Safresh1 $digits =~ tr/0-9//cd; 12259f11ffb7Safresh1 12269f11ffb7Safresh1 # Now do the rounding. We could easily make the regex substitution 12279f11ffb7Safresh1 # handle all cases, but we avoid using the regex engine when it is 12289f11ffb7Safresh1 # simple to avoid it. 12299f11ffb7Safresh1 12309f11ffb7Safresh1 if ($round_up) { 12319f11ffb7Safresh1 my $last_digit = substr($digits, -1, 1); 12329f11ffb7Safresh1 if ($last_digit lt '9') { 12339f11ffb7Safresh1 substr($digits, -1, 1) = ++$last_digit; 12349f11ffb7Safresh1 } else { 1235e0680481Safresh1 $digits =~ s{([0-8])(9+)$} 1236e0680481Safresh1 { ($1 + 1) . ("0" x CORE::length($2)) }e; 12379f11ffb7Safresh1 } 12389f11ffb7Safresh1 } 12399f11ffb7Safresh1 1240e0680481Safresh1 # Convert to an object. 12419f11ffb7Safresh1 1242e0680481Safresh1 $pi = bless { 1243e0680481Safresh1 sign => '+', 1244e0680481Safresh1 _m => $LIB -> _new($digits), 1245e0680481Safresh1 _es => '-', 1246e0680481Safresh1 _e => $LIB -> _new($n - 1), 1247e0680481Safresh1 }, $class; 12489f11ffb7Safresh1 12499f11ffb7Safresh1 } else { 12509f11ffb7Safresh1 12519f11ffb7Safresh1 # For large accuracy, the arctan formulas become very inefficient with 12529f11ffb7Safresh1 # Math::BigFloat, so use Brent-Salamin (aka AGM or Gauss-Legendre). 12539f11ffb7Safresh1 12549f11ffb7Safresh1 # Use a few more digits in the intermediate computations. 1255b46d8ef2Safresh1 $n += 8; 12569f11ffb7Safresh1 12579f11ffb7Safresh1 $HALF = $class -> new($HALF) unless ref($HALF); 1258e0680481Safresh1 my ($an, $bn, $tn, $pn) 1259e0680481Safresh1 = ($class -> bone, $HALF -> copy() -> bsqrt($n), 12609f11ffb7Safresh1 $HALF -> copy() -> bmul($HALF), $class -> bone); 12619f11ffb7Safresh1 while ($pn < $n) { 12629f11ffb7Safresh1 my $prev_an = $an -> copy(); 1263e0680481Safresh1 $an = $an -> badd($bn) -> bmul($HALF, $n); 1264e0680481Safresh1 $bn = $bn -> bmul($prev_an) -> bsqrt($n); 1265e0680481Safresh1 $prev_an = $prev_an -> bsub($an); 1266e0680481Safresh1 $tn = $tn -> bsub($pn * $prev_an * $prev_an); 1267e0680481Safresh1 $pn = $pn -> badd($pn); 12689f11ffb7Safresh1 } 1269e0680481Safresh1 $an = $an -> badd($bn); 1270e0680481Safresh1 $an = $an -> bmul($an, $n) -> bdiv(4 * $tn, $n); 12719f11ffb7Safresh1 1272e0680481Safresh1 $an = $an -> round(@r); 12739f11ffb7Safresh1 $pi = $an; 12749f11ffb7Safresh1 } 12759f11ffb7Safresh1 12769f11ffb7Safresh1 if (defined $r[0]) { 12779f11ffb7Safresh1 $pi -> accuracy($r[0]); 12789f11ffb7Safresh1 } elsif (defined $r[1]) { 12799f11ffb7Safresh1 $pi -> precision($r[1]); 12809f11ffb7Safresh1 } 12819f11ffb7Safresh1 1282*3d61058aSafresh1 for my $key (qw/ sign _m _es _e accuracy precision /) { 12839f11ffb7Safresh1 $self -> {$key} = $pi -> {$key}; 12849f11ffb7Safresh1 } 12859f11ffb7Safresh1 1286e0680481Safresh1 return $downgrade -> new($self -> bdstr(), @r) 1287e0680481Safresh1 if defined($downgrade) && $self->is_int(); 12889f11ffb7Safresh1 return $self; 1289b8851fccSafresh1} 1290b8851fccSafresh1 1291b8851fccSafresh1sub copy { 1292e0680481Safresh1 my ($x, $class); 1293e0680481Safresh1 if (ref($_[0])) { # $y = $x -> copy() 1294e0680481Safresh1 $x = shift; 1295e0680481Safresh1 $class = ref($x); 1296e0680481Safresh1 } else { # $y = Math::BigInt -> copy($y) 1297e0680481Safresh1 $class = shift; 1298e0680481Safresh1 $x = shift; 1299e0680481Safresh1 } 1300b8851fccSafresh1 1301e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @_; 1302b8851fccSafresh1 1303b8851fccSafresh1 my $copy = bless {}, $class; 1304b8851fccSafresh1 1305e0680481Safresh1 $copy->{sign} = $x->{sign}; 1306e0680481Safresh1 $copy->{_es} = $x->{_es}; 1307e0680481Safresh1 $copy->{_m} = $LIB->_copy($x->{_m}); 1308e0680481Safresh1 $copy->{_e} = $LIB->_copy($x->{_e}); 1309*3d61058aSafresh1 $copy->{accuracy} = $x->{accuracy} if exists $x->{accuracy}; 1310*3d61058aSafresh1 $copy->{precision} = $x->{precision} if exists $x->{precision}; 1311b8851fccSafresh1 1312b8851fccSafresh1 return $copy; 1313b8851fccSafresh1} 1314b8851fccSafresh1 1315e0680481Safresh1sub as_int { 13169f11ffb7Safresh1 # return copy as a bigint representation of this Math::BigFloat number 1317e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 1318e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 1319b8851fccSafresh1 1320e0680481Safresh1 return $x -> copy() if $x -> isa("Math::BigInt"); 13219f11ffb7Safresh1 1322*3d61058aSafresh1 # Disable upgrading and downgrading. 1323b8851fccSafresh1 1324e0680481Safresh1 require Math::BigInt; 1325e0680481Safresh1 my $upg = Math::BigInt -> upgrade(); 1326e0680481Safresh1 my $dng = Math::BigInt -> downgrade(); 1327e0680481Safresh1 Math::BigInt -> upgrade(undef); 1328e0680481Safresh1 Math::BigInt -> downgrade(undef); 13299f11ffb7Safresh1 1330*3d61058aSafresh1 # Copy the value. 1331*3d61058aSafresh1 1332e0680481Safresh1 my $y; 1333e0680481Safresh1 if ($x -> is_inf()) { 1334e0680481Safresh1 $y = Math::BigInt -> binf($x->sign()); 1335e0680481Safresh1 } elsif ($x -> is_nan()) { 1336e0680481Safresh1 $y = Math::BigInt -> bnan(); 1337e0680481Safresh1 } else { 1338e0680481Safresh1 $y = $LIB->_copy($x->{_m}); 13399f11ffb7Safresh1 if ($x->{_es} eq '-') { # < 0 1340e0680481Safresh1 $y = $LIB->_rsft($y, $x->{_e}, 10); 1341b46d8ef2Safresh1 } elsif (! $LIB->_is_zero($x->{_e})) { # > 0 1342e0680481Safresh1 $y = $LIB->_lsft($y, $x->{_e}, 10); 13439f11ffb7Safresh1 } 1344e0680481Safresh1 $y = Math::BigInt->new($x->{sign} . $LIB->_str($y)); 1345e0680481Safresh1 } 1346e0680481Safresh1 1347*3d61058aSafresh1 # Copy the remaining instance variables. 1348*3d61058aSafresh1 1349*3d61058aSafresh1 ($y->{accuracy}, $y->{precision}) = ($x->{accuracy}, $x->{precision}); 1350*3d61058aSafresh1 1351*3d61058aSafresh1 # Restore upgrading and downgrading. 1352e0680481Safresh1 1353e0680481Safresh1 Math::BigInt -> upgrade($upg); 1354e0680481Safresh1 Math::BigInt -> downgrade($dng); 1355e0680481Safresh1 1356e0680481Safresh1 return $y; 1357e0680481Safresh1} 1358e0680481Safresh1 1359e0680481Safresh1sub as_float { 1360e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 1361e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 1362e0680481Safresh1 1363e0680481Safresh1 return $x -> copy() if $x -> isa("Math::BigFloat"); 1364e0680481Safresh1 1365*3d61058aSafresh1 # Disable upgrading and downgrading. 1366e0680481Safresh1 1367e0680481Safresh1 my $upg = Math::BigFloat -> upgrade(); 1368e0680481Safresh1 my $dng = Math::BigFloat -> downgrade(); 1369e0680481Safresh1 Math::BigFloat -> upgrade(undef); 1370e0680481Safresh1 Math::BigFloat -> downgrade(undef); 1371e0680481Safresh1 1372*3d61058aSafresh1 # Copy the value. 1373*3d61058aSafresh1 1374e0680481Safresh1 my $y = Math::BigFloat -> new($x); 1375e0680481Safresh1 1376*3d61058aSafresh1 # Copy the remaining instance variables. 1377*3d61058aSafresh1 1378*3d61058aSafresh1 ($y->{accuracy}, $y->{precision}) = ($x->{accuracy}, $x->{precision}); 1379*3d61058aSafresh1 1380*3d61058aSafresh1 # Restore upgrading and downgrading. 1381e0680481Safresh1 1382e0680481Safresh1 Math::BigFloat -> upgrade($upg); 1383e0680481Safresh1 Math::BigFloat -> downgrade($dng); 1384e0680481Safresh1 1385e0680481Safresh1 return $y; 1386b8851fccSafresh1} 1387b8851fccSafresh1 1388*3d61058aSafresh1sub as_rat { 1389*3d61058aSafresh1 # return copy as a Math::BigRat representation of this Math::BigFloat 1390*3d61058aSafresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 1391*3d61058aSafresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 1392*3d61058aSafresh1 1393*3d61058aSafresh1 return $x -> copy() if $x -> isa("Math::BigRat"); 1394*3d61058aSafresh1 1395*3d61058aSafresh1 # Disable upgrading and downgrading. 1396*3d61058aSafresh1 1397*3d61058aSafresh1 require Math::BigRat; 1398*3d61058aSafresh1 my $upg = Math::BigRat -> upgrade(); 1399*3d61058aSafresh1 my $dng = Math::BigRat -> downgrade(); 1400*3d61058aSafresh1 Math::BigRat -> upgrade(undef); 1401*3d61058aSafresh1 Math::BigRat -> downgrade(undef); 1402*3d61058aSafresh1 1403*3d61058aSafresh1 # Copy the value. 1404*3d61058aSafresh1 1405*3d61058aSafresh1 my $y; 1406*3d61058aSafresh1 if ($x -> is_inf()) { 1407*3d61058aSafresh1 $y = Math::BigRat -> binf($x -> sign()); 1408*3d61058aSafresh1 } elsif ($x -> is_nan()) { 1409*3d61058aSafresh1 $y = Math::BigRat -> bnan(); 1410*3d61058aSafresh1 } else { 1411*3d61058aSafresh1 my @flt_parts = ($x->{sign}, $x->{_m}, $x->{_es}, $x->{_e}); 1412*3d61058aSafresh1 my @rat_parts = $class -> _flt_lib_parts_to_rat_lib_parts(@flt_parts); 1413*3d61058aSafresh1 $y = Math::BigRat -> new($rat_parts[0] . $LIB -> _str($rat_parts[1]) 1414*3d61058aSafresh1 . '/' . $LIB -> _str($rat_parts[2])); 1415*3d61058aSafresh1 } 1416*3d61058aSafresh1 1417*3d61058aSafresh1 # Copy the remaining instance variables. 1418*3d61058aSafresh1 1419*3d61058aSafresh1 ($y->{accuracy}, $y->{precision}) = ($x->{accuracy}, $x->{precision}); 1420*3d61058aSafresh1 1421*3d61058aSafresh1 # Restore upgrading and downgrading. 1422*3d61058aSafresh1 1423*3d61058aSafresh1 Math::BigRat -> upgrade($upg); 1424*3d61058aSafresh1 Math::BigRat -> downgrade($dng); 1425*3d61058aSafresh1 1426*3d61058aSafresh1 return $y; 1427*3d61058aSafresh1} 1428*3d61058aSafresh1 14299f11ffb7Safresh1############################################################################### 14309f11ffb7Safresh1# Boolean methods 14319f11ffb7Safresh1############################################################################### 1432b8851fccSafresh1 14339f11ffb7Safresh1sub is_zero { 14349f11ffb7Safresh1 # return true if arg (BFLOAT or num_str) is zero 1435e0680481Safresh1 my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); 14369f11ffb7Safresh1 1437b46d8ef2Safresh1 ($x->{sign} eq '+' && $LIB->_is_zero($x->{_m})) ? 1 : 0; 1438b8851fccSafresh1} 1439b8851fccSafresh1 14409f11ffb7Safresh1sub is_one { 14419f11ffb7Safresh1 # return true if arg (BFLOAT or num_str) is +1 or -1 if signis given 1442e0680481Safresh1 my (undef, $x, $sign) = ref($_[0]) ? (undef, @_) : objectify(1, @_); 14439f11ffb7Safresh1 14449f11ffb7Safresh1 $sign = '+' if !defined $sign || $sign ne '-'; 14459f11ffb7Safresh1 14469f11ffb7Safresh1 ($x->{sign} eq $sign && 1447b46d8ef2Safresh1 $LIB->_is_zero($x->{_e}) && 1448b46d8ef2Safresh1 $LIB->_is_one($x->{_m})) ? 1 : 0; 1449b8851fccSafresh1} 1450b8851fccSafresh1 14519f11ffb7Safresh1sub is_odd { 14529f11ffb7Safresh1 # return true if arg (BFLOAT or num_str) is odd or false if even 1453e0680481Safresh1 my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); 14549f11ffb7Safresh1 14559f11ffb7Safresh1 (($x->{sign} =~ /^[+-]$/) && # NaN & +-inf aren't 1456b46d8ef2Safresh1 ($LIB->_is_zero($x->{_e})) && 1457b46d8ef2Safresh1 ($LIB->_is_odd($x->{_m}))) ? 1 : 0; 1458b8851fccSafresh1} 1459b8851fccSafresh1 14609f11ffb7Safresh1sub is_even { 14619f11ffb7Safresh1 # return true if arg (BINT or num_str) is even or false if odd 1462e0680481Safresh1 my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); 14639f11ffb7Safresh1 14649f11ffb7Safresh1 (($x->{sign} =~ /^[+-]$/) && # NaN & +-inf aren't 14659f11ffb7Safresh1 ($x->{_es} eq '+') && # 123.45 isn't 1466b46d8ef2Safresh1 ($LIB->_is_even($x->{_m}))) ? 1 : 0; # but 1200 is 1467b8851fccSafresh1} 1468b8851fccSafresh1 14699f11ffb7Safresh1sub is_int { 14709f11ffb7Safresh1 # return true if arg (BFLOAT or num_str) is an integer 1471e0680481Safresh1 my (undef, $x) = ref($_[0]) ? (undef, @_) : objectify(1, @_); 14729f11ffb7Safresh1 14739f11ffb7Safresh1 (($x->{sign} =~ /^[+-]$/) && # NaN and +-inf aren't 14749f11ffb7Safresh1 ($x->{_es} eq '+')) ? 1 : 0; # 1e-1 => no integer 1475b8851fccSafresh1} 1476b8851fccSafresh1 14779f11ffb7Safresh1############################################################################### 14789f11ffb7Safresh1# Comparison methods 14799f11ffb7Safresh1############################################################################### 1480b8851fccSafresh1 14819f11ffb7Safresh1sub bcmp { 1482b8851fccSafresh1 # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort) 1483b8851fccSafresh1 1484b8851fccSafresh1 # set up parameters 1485e0680481Safresh1 my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 1486e0680481Safresh1 ? (ref($_[0]), @_) 1487e0680481Safresh1 : objectify(2, @_); 1488b8851fccSafresh1 1489e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 1490b8851fccSafresh1 1491b8851fccSafresh1 # Handle all 'nan' cases. 1492b8851fccSafresh1 1493eac174f2Safresh1 return if ($x->{sign} eq $nan) || ($y->{sign} eq $nan); 1494b8851fccSafresh1 1495b8851fccSafresh1 # Handle all '+inf' and '-inf' cases. 1496b8851fccSafresh1 1497b8851fccSafresh1 return 0 if ($x->{sign} eq '+inf' && $y->{sign} eq '+inf' || 1498b8851fccSafresh1 $x->{sign} eq '-inf' && $y->{sign} eq '-inf'); 1499b8851fccSafresh1 return +1 if $x->{sign} eq '+inf'; # x = +inf and y < +inf 1500b8851fccSafresh1 return -1 if $x->{sign} eq '-inf'; # x = -inf and y > -inf 1501b8851fccSafresh1 return -1 if $y->{sign} eq '+inf'; # x < +inf and y = +inf 1502b8851fccSafresh1 return +1 if $y->{sign} eq '-inf'; # x > -inf and y = -inf 1503b8851fccSafresh1 1504b8851fccSafresh1 # Handle all cases with opposite signs. 1505b8851fccSafresh1 1506b8851fccSafresh1 return +1 if $x->{sign} eq '+' && $y->{sign} eq '-'; # also does 0 <=> -y 1507b8851fccSafresh1 return -1 if $x->{sign} eq '-' && $y->{sign} eq '+'; # also does -x <=> 0 1508b8851fccSafresh1 1509b8851fccSafresh1 # Handle all remaining zero cases. 1510b8851fccSafresh1 1511b8851fccSafresh1 my $xz = $x->is_zero(); 1512b8851fccSafresh1 my $yz = $y->is_zero(); 1513b8851fccSafresh1 return 0 if $xz && $yz; # 0 <=> 0 1514b8851fccSafresh1 return -1 if $xz && $y->{sign} eq '+'; # 0 <=> +y 1515b8851fccSafresh1 return +1 if $yz && $x->{sign} eq '+'; # +x <=> 0 1516b8851fccSafresh1 1517b8851fccSafresh1 # Both arguments are now finite, non-zero numbers with the same sign. 1518b8851fccSafresh1 1519b8851fccSafresh1 my $cmp; 1520b8851fccSafresh1 1521b8851fccSafresh1 # The next step is to compare the exponents, but since each mantissa is an 1522b8851fccSafresh1 # integer of arbitrary value, the exponents must be normalized by the length 1523b8851fccSafresh1 # of the mantissas before we can compare them. 1524b8851fccSafresh1 1525b46d8ef2Safresh1 my $mxl = $LIB->_len($x->{_m}); 1526b46d8ef2Safresh1 my $myl = $LIB->_len($y->{_m}); 1527b8851fccSafresh1 1528e0680481Safresh1 # If the mantissas have the same length, there is no point in normalizing 1529e0680481Safresh1 # the exponents by the length of the mantissas, so treat that as a special 1530e0680481Safresh1 # case. 1531b8851fccSafresh1 1532b8851fccSafresh1 if ($mxl == $myl) { 1533b8851fccSafresh1 1534b8851fccSafresh1 # First handle the two cases where the exponents have different signs. 1535b8851fccSafresh1 1536b8851fccSafresh1 if ($x->{_es} eq '+' && $y->{_es} eq '-') { 1537b8851fccSafresh1 $cmp = +1; 15389f11ffb7Safresh1 } elsif ($x->{_es} eq '-' && $y->{_es} eq '+') { 1539b8851fccSafresh1 $cmp = -1; 1540b8851fccSafresh1 } 1541b8851fccSafresh1 1542b8851fccSafresh1 # Then handle the case where the exponents have the same sign. 1543b8851fccSafresh1 1544b8851fccSafresh1 else { 1545b46d8ef2Safresh1 $cmp = $LIB->_acmp($x->{_e}, $y->{_e}); 1546b8851fccSafresh1 $cmp = -$cmp if $x->{_es} eq '-'; 1547b8851fccSafresh1 } 1548b8851fccSafresh1 1549b8851fccSafresh1 # Adjust for the sign, which is the same for x and y, and bail out if 1550b8851fccSafresh1 # we're done. 1551b8851fccSafresh1 1552b8851fccSafresh1 $cmp = -$cmp if $x->{sign} eq '-'; # 124 > 123, but -124 < -123 1553b8851fccSafresh1 return $cmp if $cmp; 1554b8851fccSafresh1 1555b8851fccSafresh1 } 1556b8851fccSafresh1 1557b8851fccSafresh1 # We must normalize each exponent by the length of the corresponding 1558b8851fccSafresh1 # mantissa. Life is a lot easier if we first make both exponents 1559b8851fccSafresh1 # non-negative. We do this by adding the same positive value to both 1560b8851fccSafresh1 # exponent. This is safe, because when comparing the exponents, only the 1561b8851fccSafresh1 # relative difference is important. 1562b8851fccSafresh1 1563b8851fccSafresh1 my $ex; 1564b8851fccSafresh1 my $ey; 1565b8851fccSafresh1 1566b8851fccSafresh1 if ($x->{_es} eq '+') { 1567b8851fccSafresh1 1568e0680481Safresh1 # If the exponent of x is >= 0 and the exponent of y is >= 0, there is 1569e0680481Safresh1 # no need to do anything special. 1570b8851fccSafresh1 1571b8851fccSafresh1 if ($y->{_es} eq '+') { 1572b46d8ef2Safresh1 $ex = $LIB->_copy($x->{_e}); 1573b46d8ef2Safresh1 $ey = $LIB->_copy($y->{_e}); 1574b8851fccSafresh1 } 1575b8851fccSafresh1 1576b8851fccSafresh1 # If the exponent of x is >= 0 and the exponent of y is < 0, add the 1577b8851fccSafresh1 # absolute value of the exponent of y to both. 1578b8851fccSafresh1 1579b8851fccSafresh1 else { 1580b46d8ef2Safresh1 $ex = $LIB->_copy($x->{_e}); 1581b46d8ef2Safresh1 $ex = $LIB->_add($ex, $y->{_e}); # ex + |ey| 1582b46d8ef2Safresh1 $ey = $LIB->_zero(); # -ex + |ey| = 0 1583b8851fccSafresh1 } 1584b8851fccSafresh1 1585b8851fccSafresh1 } else { 1586b8851fccSafresh1 1587b8851fccSafresh1 # If the exponent of x is < 0 and the exponent of y is >= 0, add the 1588b8851fccSafresh1 # absolute value of the exponent of x to both. 1589b8851fccSafresh1 1590b8851fccSafresh1 if ($y->{_es} eq '+') { 1591b46d8ef2Safresh1 $ex = $LIB->_zero(); # -ex + |ex| = 0 1592b46d8ef2Safresh1 $ey = $LIB->_copy($y->{_e}); 1593b46d8ef2Safresh1 $ey = $LIB->_add($ey, $x->{_e}); # ey + |ex| 1594b8851fccSafresh1 } 1595b8851fccSafresh1 1596b8851fccSafresh1 # If the exponent of x is < 0 and the exponent of y is < 0, add the 1597b8851fccSafresh1 # absolute values of both exponents to both exponents. 1598b8851fccSafresh1 1599b8851fccSafresh1 else { 1600b46d8ef2Safresh1 $ex = $LIB->_copy($y->{_e}); # -ex + |ey| + |ex| = |ey| 1601b46d8ef2Safresh1 $ey = $LIB->_copy($x->{_e}); # -ey + |ex| + |ey| = |ex| 1602b8851fccSafresh1 } 1603b8851fccSafresh1 1604b8851fccSafresh1 } 1605b8851fccSafresh1 1606b8851fccSafresh1 # Now we can normalize the exponents by adding lengths of the mantissas. 1607b8851fccSafresh1 1608b46d8ef2Safresh1 $ex = $LIB->_add($ex, $LIB->_new($mxl)); 1609b46d8ef2Safresh1 $ey = $LIB->_add($ey, $LIB->_new($myl)); 1610b8851fccSafresh1 1611b8851fccSafresh1 # We're done if the exponents are different. 1612b8851fccSafresh1 1613b46d8ef2Safresh1 $cmp = $LIB->_acmp($ex, $ey); 1614b8851fccSafresh1 $cmp = -$cmp if $x->{sign} eq '-'; # 124 > 123, but -124 < -123 1615b8851fccSafresh1 return $cmp if $cmp; 1616b8851fccSafresh1 1617b8851fccSafresh1 # Compare the mantissas, but first normalize them by padding the shorter 1618e0680481Safresh1 # mantissa with zeros (shift left) until it has the same length as the 1619e0680481Safresh1 # longer mantissa. 1620b8851fccSafresh1 1621b8851fccSafresh1 my $mx = $x->{_m}; 1622b8851fccSafresh1 my $my = $y->{_m}; 1623b8851fccSafresh1 1624b8851fccSafresh1 if ($mxl > $myl) { 1625b46d8ef2Safresh1 $my = $LIB->_lsft($LIB->_copy($my), $LIB->_new($mxl - $myl), 10); 1626b8851fccSafresh1 } elsif ($mxl < $myl) { 1627b46d8ef2Safresh1 $mx = $LIB->_lsft($LIB->_copy($mx), $LIB->_new($myl - $mxl), 10); 1628b8851fccSafresh1 } 1629b8851fccSafresh1 1630b46d8ef2Safresh1 $cmp = $LIB->_acmp($mx, $my); 1631b8851fccSafresh1 $cmp = -$cmp if $x->{sign} eq '-'; # 124 > 123, but -124 < -123 1632b8851fccSafresh1 return $cmp; 1633b8851fccSafresh1 1634b8851fccSafresh1} 1635b8851fccSafresh1 16369f11ffb7Safresh1sub bacmp { 1637b8851fccSafresh1 # Compares 2 values, ignoring their signs. 1638b8851fccSafresh1 # Returns one of undef, <0, =0, >0. (suitable for sort) 1639b8851fccSafresh1 1640b8851fccSafresh1 # set up parameters 1641e0680481Safresh1 my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 1642e0680481Safresh1 ? (ref($_[0]), @_) 1643e0680481Safresh1 : objectify(2, @_); 1644b8851fccSafresh1 1645e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 1646b8851fccSafresh1 1647b8851fccSafresh1 # handle +-inf and NaN's 16489f11ffb7Safresh1 if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/) { 1649eac174f2Safresh1 return if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); 1650b8851fccSafresh1 return 0 if ($x->is_inf() && $y->is_inf()); 1651b8851fccSafresh1 return 1 if ($x->is_inf() && !$y->is_inf()); 1652b8851fccSafresh1 return -1; 1653b8851fccSafresh1 } 1654b8851fccSafresh1 1655b8851fccSafresh1 # shortcut 1656b8851fccSafresh1 my $xz = $x->is_zero(); 1657b8851fccSafresh1 my $yz = $y->is_zero(); 1658b8851fccSafresh1 return 0 if $xz && $yz; # 0 <=> 0 1659b8851fccSafresh1 return -1 if $xz && !$yz; # 0 <=> +y 1660b8851fccSafresh1 return 1 if $yz && !$xz; # +x <=> 0 1661b8851fccSafresh1 1662b8851fccSafresh1 # adjust so that exponents are equal 1663b46d8ef2Safresh1 my $lxm = $LIB->_len($x->{_m}); 1664b46d8ef2Safresh1 my $lym = $LIB->_len($y->{_m}); 1665b8851fccSafresh1 my ($xes, $yes) = (1, 1); 1666b8851fccSafresh1 $xes = -1 if $x->{_es} ne '+'; 1667b8851fccSafresh1 $yes = -1 if $y->{_es} ne '+'; 1668b8851fccSafresh1 # the numify somewhat limits our length, but makes it much faster 1669b46d8ef2Safresh1 my $lx = $lxm + $xes * $LIB->_num($x->{_e}); 1670b46d8ef2Safresh1 my $ly = $lym + $yes * $LIB->_num($y->{_e}); 1671b8851fccSafresh1 my $l = $lx - $ly; 1672b8851fccSafresh1 return $l <=> 0 if $l != 0; 1673b8851fccSafresh1 1674b8851fccSafresh1 # lengths (corrected by exponent) are equal 1675b8851fccSafresh1 # so make mantissa equal-length by padding with zero (shift left) 1676b8851fccSafresh1 my $diff = $lxm - $lym; 1677b8851fccSafresh1 my $xm = $x->{_m}; # not yet copy it 1678b8851fccSafresh1 my $ym = $y->{_m}; 16799f11ffb7Safresh1 if ($diff > 0) { 1680b46d8ef2Safresh1 $ym = $LIB->_copy($y->{_m}); 1681b46d8ef2Safresh1 $ym = $LIB->_lsft($ym, $LIB->_new($diff), 10); 16829f11ffb7Safresh1 } elsif ($diff < 0) { 1683b46d8ef2Safresh1 $xm = $LIB->_copy($x->{_m}); 1684b46d8ef2Safresh1 $xm = $LIB->_lsft($xm, $LIB->_new(-$diff), 10); 1685b8851fccSafresh1 } 1686b46d8ef2Safresh1 $LIB->_acmp($xm, $ym); 1687b8851fccSafresh1} 1688b8851fccSafresh1 16899f11ffb7Safresh1############################################################################### 16909f11ffb7Safresh1# Arithmetic methods 16919f11ffb7Safresh1############################################################################### 16929f11ffb7Safresh1 16939f11ffb7Safresh1sub bneg { 16949f11ffb7Safresh1 # (BINT or num_str) return BINT 16959f11ffb7Safresh1 # negate number or make a negated number from string 1696e0680481Safresh1 my (undef, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); 16979f11ffb7Safresh1 16989f11ffb7Safresh1 return $x if $x->modify('bneg'); 16999f11ffb7Safresh1 1700e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan(); 1701eac174f2Safresh1 1702e0680481Safresh1 # For +0 do not negate (to have always normalized +0). 1703e0680481Safresh1 $x->{sign} =~ tr/+-/-+/ 1704e0680481Safresh1 unless $x->{sign} eq '+' && $LIB->_is_zero($x->{_m}); 1705e0680481Safresh1 1706e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade) 1707e0680481Safresh1 && ($x -> is_int() || $x -> is_inf() || $x -> is_nan()); 1708e0680481Safresh1 return $x -> round(@r); 17099f11ffb7Safresh1} 17109f11ffb7Safresh1 17119f11ffb7Safresh1sub bnorm { 1712e0680481Safresh1 # bnorm() can't support rounding, because bround() and bfround() call 1713e0680481Safresh1 # bnorm(), which would recurse indefinitely. 1714e0680481Safresh1 17159f11ffb7Safresh1 # adjust m and e so that m is smallest possible 1716e0680481Safresh1 my (undef, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); 1717e0680481Safresh1 1718e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 17199f11ffb7Safresh1 1720eac174f2Safresh1 # inf, nan etc 1721eac174f2Safresh1 if ($x->{sign} !~ /^[+-]$/) { 1722eac174f2Safresh1 return $downgrade -> new($x) if defined $downgrade; 1723eac174f2Safresh1 return $x; 1724eac174f2Safresh1 } 17259f11ffb7Safresh1 1726b46d8ef2Safresh1 my $zeros = $LIB->_zeros($x->{_m}); # correct for trailing zeros 17279f11ffb7Safresh1 if ($zeros != 0) { 1728b46d8ef2Safresh1 my $z = $LIB->_new($zeros); 1729b46d8ef2Safresh1 $x->{_m} = $LIB->_rsft($x->{_m}, $z, 10); 17309f11ffb7Safresh1 if ($x->{_es} eq '-') { 1731b46d8ef2Safresh1 if ($LIB->_acmp($x->{_e}, $z) >= 0) { 1732b46d8ef2Safresh1 $x->{_e} = $LIB->_sub($x->{_e}, $z); 1733b46d8ef2Safresh1 $x->{_es} = '+' if $LIB->_is_zero($x->{_e}); 17349f11ffb7Safresh1 } else { 1735b46d8ef2Safresh1 $x->{_e} = $LIB->_sub($LIB->_copy($z), $x->{_e}); 17369f11ffb7Safresh1 $x->{_es} = '+'; 17379f11ffb7Safresh1 } 17389f11ffb7Safresh1 } else { 1739b46d8ef2Safresh1 $x->{_e} = $LIB->_add($x->{_e}, $z); 17409f11ffb7Safresh1 } 17419f11ffb7Safresh1 } else { 17429f11ffb7Safresh1 # $x can only be 0Ey if there are no trailing zeros ('0' has 0 trailing 1743e0680481Safresh1 # zeros). So, for something like 0Ey, set y to 0, and -0 => +0 1744e0680481Safresh1 if ($LIB->_is_zero($x->{_m})) { 1745e0680481Safresh1 $x->{sign} = '+'; 1746e0680481Safresh1 $x->{_es} = '+'; 1747e0680481Safresh1 $x->{_e} = $LIB->_zero(); 1748e0680481Safresh1 } 17499f11ffb7Safresh1 } 17509f11ffb7Safresh1 1751e0680481Safresh1 return $downgrade -> new($x) 1752e0680481Safresh1 if defined($downgrade) && $x->is_int(); 1753e0680481Safresh1 return $x; 17549f11ffb7Safresh1} 17559f11ffb7Safresh1 17569f11ffb7Safresh1sub binc { 17579f11ffb7Safresh1 # increment arg by one 17589f11ffb7Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 17599f11ffb7Safresh1 17609f11ffb7Safresh1 return $x if $x->modify('binc'); 17619f11ffb7Safresh1 1762e0680481Safresh1 # Inf and NaN 1763e0680481Safresh1 1764e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan(); 1765e0680481Safresh1 return $x -> binf($x->{sign}, @r) if $x -> is_inf(); 1766e0680481Safresh1 1767e0680481Safresh1 # Non-integer 1768e0680481Safresh1 17699f11ffb7Safresh1 if ($x->{_es} eq '-') { 1770e0680481Safresh1 return $x->badd($class->bone(), @r); 17719f11ffb7Safresh1 } 17729f11ffb7Safresh1 1773e0680481Safresh1 # If the exponent is non-zero, convert the internal representation, so that, 1774e0680481Safresh1 # e.g., 12e+3 becomes 12000e+0 and we can easily increment the mantissa. 1775e0680481Safresh1 1776e0680481Safresh1 if (!$LIB->_is_zero($x->{_e})) { 1777b46d8ef2Safresh1 $x->{_m} = $LIB->_lsft($x->{_m}, $x->{_e}, 10); # 1e2 => 100 1778b46d8ef2Safresh1 $x->{_e} = $LIB->_zero(); # normalize 17799f11ffb7Safresh1 $x->{_es} = '+'; 17809f11ffb7Safresh1 # we know that the last digit of $x will be '1' or '9', depending on the 17819f11ffb7Safresh1 # sign 17829f11ffb7Safresh1 } 1783e0680481Safresh1 17849f11ffb7Safresh1 # now $x->{_e} == 0 17859f11ffb7Safresh1 if ($x->{sign} eq '+') { 1786b46d8ef2Safresh1 $x->{_m} = $LIB->_inc($x->{_m}); 17879f11ffb7Safresh1 return $x->bnorm()->bround(@r); 17889f11ffb7Safresh1 } elsif ($x->{sign} eq '-') { 1789b46d8ef2Safresh1 $x->{_m} = $LIB->_dec($x->{_m}); 1790b46d8ef2Safresh1 $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # -1 +1 => -0 => +0 17919f11ffb7Safresh1 return $x->bnorm()->bround(@r); 17929f11ffb7Safresh1 } 1793e0680481Safresh1 1794e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 1795e0680481Safresh1 if defined($downgrade) && $x -> is_int(); 1796e0680481Safresh1 return $x; 17979f11ffb7Safresh1} 17989f11ffb7Safresh1 17999f11ffb7Safresh1sub bdec { 18009f11ffb7Safresh1 # decrement arg by one 18019f11ffb7Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 18029f11ffb7Safresh1 18039f11ffb7Safresh1 return $x if $x->modify('bdec'); 18049f11ffb7Safresh1 1805e0680481Safresh1 # Inf and NaN 1806e0680481Safresh1 1807e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan(); 1808e0680481Safresh1 return $x -> binf($x->{sign}, @r) if $x -> is_inf(); 1809e0680481Safresh1 1810e0680481Safresh1 # Non-integer 1811e0680481Safresh1 18129f11ffb7Safresh1 if ($x->{_es} eq '-') { 1813e0680481Safresh1 return $x->badd($class->bone('-'), @r); 18149f11ffb7Safresh1 } 18159f11ffb7Safresh1 1816e0680481Safresh1 # If the exponent is non-zero, convert the internal representation, so that, 1817e0680481Safresh1 # e.g., 12e+3 becomes 12000e+0 and we can easily increment the mantissa. 1818e0680481Safresh1 1819b46d8ef2Safresh1 if (!$LIB->_is_zero($x->{_e})) { 1820b46d8ef2Safresh1 $x->{_m} = $LIB->_lsft($x->{_m}, $x->{_e}, 10); # 1e2 => 100 1821b46d8ef2Safresh1 $x->{_e} = $LIB->_zero(); # normalize 18229f11ffb7Safresh1 $x->{_es} = '+'; 18239f11ffb7Safresh1 } 1824e0680481Safresh1 18259f11ffb7Safresh1 # now $x->{_e} == 0 18269f11ffb7Safresh1 my $zero = $x->is_zero(); 1827e0680481Safresh1 if (($x->{sign} eq '-') || $zero) { # x <= 0 1828b46d8ef2Safresh1 $x->{_m} = $LIB->_inc($x->{_m}); 18299f11ffb7Safresh1 $x->{sign} = '-' if $zero; # 0 => 1 => -1 1830b46d8ef2Safresh1 $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # -1 +1 => -0 => +0 18319f11ffb7Safresh1 return $x->bnorm()->round(@r); 18329f11ffb7Safresh1 } 1833e0680481Safresh1 elsif ($x->{sign} eq '+') { # x > 0 1834b46d8ef2Safresh1 $x->{_m} = $LIB->_dec($x->{_m}); 18359f11ffb7Safresh1 return $x->bnorm()->round(@r); 18369f11ffb7Safresh1 } 1837e0680481Safresh1 1838e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 1839e0680481Safresh1 if defined($downgrade) && $x -> is_int(); 1840e0680481Safresh1 return $x -> round(@r); 18419f11ffb7Safresh1} 18429f11ffb7Safresh1 18439f11ffb7Safresh1sub badd { 1844b8851fccSafresh1 # set up parameters 1845e0680481Safresh1 my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 1846e0680481Safresh1 ? (ref($_[0]), @_) 1847e0680481Safresh1 : objectify(2, @_); 1848b8851fccSafresh1 1849b8851fccSafresh1 return $x if $x->modify('badd'); 1850b8851fccSafresh1 1851b8851fccSafresh1 # inf and NaN handling 1852eac174f2Safresh1 if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/) { 1853eac174f2Safresh1 1854e0680481Safresh1 # $x is NaN and/or $y is NaN 1855eac174f2Safresh1 if ($x->{sign} eq $nan || $y->{sign} eq $nan) { 1856e0680481Safresh1 $x = $x->bnan(); 1857b8851fccSafresh1 } 1858eac174f2Safresh1 1859e0680481Safresh1 # $x is Inf and $y is Inf 1860eac174f2Safresh1 elsif ($x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/) { 1861e0680481Safresh1 # +Inf + +Inf or -Inf + -Inf => same, rest is NaN 1862e0680481Safresh1 $x = $x->bnan() if $x->{sign} ne $y->{sign}; 1863eac174f2Safresh1 } 1864eac174f2Safresh1 1865e0680481Safresh1 # +-inf + something => +-inf; something +-inf => +-inf 1866eac174f2Safresh1 elsif ($y->{sign} =~ /^[+-]inf$/) { 1867eac174f2Safresh1 $x->{sign} = $y->{sign}; 1868eac174f2Safresh1 } 1869eac174f2Safresh1 1870e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) if defined $downgrade; 1871e0680481Safresh1 return $x -> round(@r); 1872b8851fccSafresh1 } 1873b8851fccSafresh1 1874e0680481Safresh1 return $upgrade->badd($x, $y, @r) if defined $upgrade; 1875b8851fccSafresh1 1876b8851fccSafresh1 $r[3] = $y; # no push! 1877b8851fccSafresh1 1878eac174f2Safresh1 # for speed: no add for $x + 0 1879eac174f2Safresh1 if ($y->is_zero()) { 1880e0680481Safresh1 $x = $x->round(@r); 1881eac174f2Safresh1 } 1882eac174f2Safresh1 1883eac174f2Safresh1 # for speed: no add for 0 + $y 1884eac174f2Safresh1 elsif ($x->is_zero()) { 1885b8851fccSafresh1 # make copy, clobbering up x (modify in place!) 1886b46d8ef2Safresh1 $x->{_e} = $LIB->_copy($y->{_e}); 1887b8851fccSafresh1 $x->{_es} = $y->{_es}; 1888b46d8ef2Safresh1 $x->{_m} = $LIB->_copy($y->{_m}); 1889b8851fccSafresh1 $x->{sign} = $y->{sign} || $nan; 1890e0680481Safresh1 $x = $x->round(@r); 1891b8851fccSafresh1 } 1892b8851fccSafresh1 1893e0680481Safresh1 # both $x and $y are non-zero 1894eac174f2Safresh1 else { 1895eac174f2Safresh1 1896b8851fccSafresh1 # take lower of the two e's and adapt m1 to it to match m2 1897b8851fccSafresh1 my $e = $y->{_e}; 1898b46d8ef2Safresh1 $e = $LIB->_zero() if !defined $e; # if no BFLOAT? 1899b46d8ef2Safresh1 $e = $LIB->_copy($e); # make copy (didn't do it yet) 1900b8851fccSafresh1 1901b8851fccSafresh1 my $es; 1902b8851fccSafresh1 1903e0680481Safresh1 ($e, $es) = $LIB -> _ssub($e, $y->{_es} || '+', $x->{_e}, $x->{_es}); 1904b8851fccSafresh1 1905b46d8ef2Safresh1 my $add = $LIB->_copy($y->{_m}); 1906b8851fccSafresh1 1907eac174f2Safresh1 if ($es eq '-') { # < 0 1908b46d8ef2Safresh1 $x->{_m} = $LIB->_lsft($x->{_m}, $e, 10); 1909e0680481Safresh1 ($x->{_e}, $x->{_es}) = $LIB -> _sadd($x->{_e}, $x->{_es}, $e, $es); 1910eac174f2Safresh1 } elsif (!$LIB->_is_zero($e)) { # > 0 1911b46d8ef2Safresh1 $add = $LIB->_lsft($add, $e, 10); 1912b8851fccSafresh1 } 1913eac174f2Safresh1 1914b8851fccSafresh1 # else: both e are the same, so just leave them 1915b8851fccSafresh1 19169f11ffb7Safresh1 if ($x->{sign} eq $y->{sign}) { 1917b46d8ef2Safresh1 $x->{_m} = $LIB->_add($x->{_m}, $add); 19189f11ffb7Safresh1 } else { 1919b8851fccSafresh1 ($x->{_m}, $x->{sign}) = 1920e0680481Safresh1 $LIB -> _sadd($x->{_m}, $x->{sign}, $add, $y->{sign}); 1921b8851fccSafresh1 } 1922b8851fccSafresh1 1923b8851fccSafresh1 # delete trailing zeros, then round 1924e0680481Safresh1 $x = $x->bnorm()->round(@r); 1925b8851fccSafresh1 } 1926b8851fccSafresh1 1927e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 1928e0680481Safresh1 if defined($downgrade) && $x -> is_int(); 1929e0680481Safresh1 return $x; # rounding already done above 1930eac174f2Safresh1} 1931eac174f2Safresh1 19329f11ffb7Safresh1sub bsub { 19339f11ffb7Safresh1 # set up parameters 1934e0680481Safresh1 my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 1935e0680481Safresh1 ? (ref($_[0]), @_) 1936e0680481Safresh1 : objectify(2, @_); 1937b8851fccSafresh1 19389f11ffb7Safresh1 return $x if $x -> modify('bsub'); 19399f11ffb7Safresh1 1940eac174f2Safresh1 if ($y -> is_zero()) { 1941e0680481Safresh1 $x = $x -> round(@r); 1942eac174f2Safresh1 } else { 19439f11ffb7Safresh1 1944eac174f2Safresh1 # To correctly handle the special case $x -> bsub($x), we note the sign 1945eac174f2Safresh1 # of $x, then flip the sign of $y, and if the sign of $x changed too, 1946eac174f2Safresh1 # then we know that $x and $y are the same object. 19479f11ffb7Safresh1 19489f11ffb7Safresh1 my $xsign = $x -> {sign}; 19499f11ffb7Safresh1 $y -> {sign} =~ tr/+-/-+/; # does nothing for NaN 19509f11ffb7Safresh1 if ($xsign ne $x -> {sign}) { 19519f11ffb7Safresh1 # special case of $x -> bsub($x) results in 0 1952eac174f2Safresh1 if ($xsign =~ /^[+-]$/) { 1953e0680481Safresh1 $x = $x -> bzero(@r); 1954eac174f2Safresh1 } else { 1955e0680481Safresh1 $x = $x -> bnan(); # NaN, -inf, +inf 19569f11ffb7Safresh1 } 1957e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) if defined $downgrade; 1958e0680481Safresh1 return $x -> round(@r); 1959eac174f2Safresh1 } 1960eac174f2Safresh1 $x = $x -> badd($y, @r); # badd does not leave internal zeros 1961eac174f2Safresh1 $y -> {sign} =~ tr/+-/-+/; # reset $y (does nothing for NaN) 1962eac174f2Safresh1 } 1963e0680481Safresh1 1964e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 1965eac174f2Safresh1 if defined($downgrade) && ($x->is_int() || $x->is_inf() || $x->is_nan()); 19669f11ffb7Safresh1 $x; # already rounded by badd() or no rounding 19679f11ffb7Safresh1} 19689f11ffb7Safresh1 19699f11ffb7Safresh1sub bmul { 19709f11ffb7Safresh1 # multiply two numbers 19719f11ffb7Safresh1 19729f11ffb7Safresh1 # set up parameters 1973e0680481Safresh1 my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 1974e0680481Safresh1 ? (ref($_[0]), @_) 1975e0680481Safresh1 : objectify(2, @_); 19769f11ffb7Safresh1 19779f11ffb7Safresh1 return $x if $x->modify('bmul'); 19789f11ffb7Safresh1 1979e0680481Safresh1 return $x->bnan(@r) if ($x->{sign} eq $nan) || ($y->{sign} eq $nan); 19809f11ffb7Safresh1 19819f11ffb7Safresh1 # inf handling 19829f11ffb7Safresh1 if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/)) { 1983e0680481Safresh1 return $x->bnan(@r) if $x->is_zero() || $y->is_zero(); 19849f11ffb7Safresh1 # result will always be +-inf: 19859f11ffb7Safresh1 # +inf * +/+inf => +inf, -inf * -/-inf => +inf 19869f11ffb7Safresh1 # +inf * -/-inf => -inf, -inf * +/+inf => -inf 1987e0680481Safresh1 return $x->binf(@r) if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/); 1988e0680481Safresh1 return $x->binf(@r) if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/); 1989e0680481Safresh1 return $x->binf('-', @r); 19909f11ffb7Safresh1 } 19919f11ffb7Safresh1 1992e0680481Safresh1 return $upgrade->bmul($x, $y, @r) if defined $upgrade; 19939f11ffb7Safresh1 19949f11ffb7Safresh1 # aEb * cEd = (a*c)E(b+d) 1995b46d8ef2Safresh1 $x->{_m} = $LIB->_mul($x->{_m}, $y->{_m}); 1996e0680481Safresh1 ($x->{_e}, $x->{_es}) 1997e0680481Safresh1 = $LIB -> _sadd($x->{_e}, $x->{_es}, $y->{_e}, $y->{_es}); 19989f11ffb7Safresh1 19999f11ffb7Safresh1 $r[3] = $y; # no push! 20009f11ffb7Safresh1 20019f11ffb7Safresh1 # adjust sign: 20029f11ffb7Safresh1 $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+'; 2003e0680481Safresh1 $x = $x->bnorm->round(@r); 2004e0680481Safresh1 2005e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 2006e0680481Safresh1 if defined($downgrade) && ($x->is_int() || $x->is_inf() || $x->is_nan()); 2007e0680481Safresh1 return $x; 20089f11ffb7Safresh1} 20099f11ffb7Safresh1 20109f11ffb7Safresh1sub bmuladd { 20119f11ffb7Safresh1 # multiply two numbers and add the third to the result 20129f11ffb7Safresh1 20139f11ffb7Safresh1 # set up parameters 2014e0680481Safresh1 my ($class, $x, $y, $z, @r) 2015e0680481Safresh1 = ref($_[0]) && ref($_[0]) eq ref($_[1]) && ref($_[1]) eq ref($_[2]) 2016e0680481Safresh1 ? (ref($_[0]), @_) 2017e0680481Safresh1 : objectify(3, @_); 20189f11ffb7Safresh1 20199f11ffb7Safresh1 return $x if $x->modify('bmuladd'); 20209f11ffb7Safresh1 2021e0680481Safresh1 return $x->bnan(@r) if (($x->{sign} eq $nan) || 20229f11ffb7Safresh1 ($y->{sign} eq $nan) || 20239f11ffb7Safresh1 ($z->{sign} eq $nan)); 20249f11ffb7Safresh1 20259f11ffb7Safresh1 # inf handling 20269f11ffb7Safresh1 if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/)) { 2027e0680481Safresh1 return $x->bnan(@r) if $x->is_zero() || $y->is_zero(); 20289f11ffb7Safresh1 # result will always be +-inf: 20299f11ffb7Safresh1 # +inf * +/+inf => +inf, -inf * -/-inf => +inf 20309f11ffb7Safresh1 # +inf * -/-inf => -inf, -inf * +/+inf => -inf 2031e0680481Safresh1 return $x->binf(@r) if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/); 2032e0680481Safresh1 return $x->binf(@r) if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/); 2033e0680481Safresh1 return $x->binf('-', @r); 20349f11ffb7Safresh1 } 20359f11ffb7Safresh1 20369f11ffb7Safresh1 # aEb * cEd = (a*c)E(b+d) 2037b46d8ef2Safresh1 $x->{_m} = $LIB->_mul($x->{_m}, $y->{_m}); 2038e0680481Safresh1 ($x->{_e}, $x->{_es}) 2039e0680481Safresh1 = $LIB -> _sadd($x->{_e}, $x->{_es}, $y->{_e}, $y->{_es}); 20409f11ffb7Safresh1 20419f11ffb7Safresh1 $r[3] = $y; # no push! 20429f11ffb7Safresh1 20439f11ffb7Safresh1 # adjust sign: 20449f11ffb7Safresh1 $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+'; 20459f11ffb7Safresh1 20469f11ffb7Safresh1 # z=inf handling (z=NaN handled above) 2047eac174f2Safresh1 if ($z->{sign} =~ /^[+-]inf$/) { 2048eac174f2Safresh1 $x->{sign} = $z->{sign}; 2049e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) if defined $downgrade; 2050e0680481Safresh1 return $x -> round(@r); 2051eac174f2Safresh1 } 20529f11ffb7Safresh1 20539f11ffb7Safresh1 # take lower of the two e's and adapt m1 to it to match m2 20549f11ffb7Safresh1 my $e = $z->{_e}; 2055b46d8ef2Safresh1 $e = $LIB->_zero() if !defined $e; # if no BFLOAT? 2056b46d8ef2Safresh1 $e = $LIB->_copy($e); # make copy (didn't do it yet) 20579f11ffb7Safresh1 20589f11ffb7Safresh1 my $es; 20599f11ffb7Safresh1 2060e0680481Safresh1 ($e, $es) = $LIB -> _ssub($e, $z->{_es} || '+', $x->{_e}, $x->{_es}); 20619f11ffb7Safresh1 2062b46d8ef2Safresh1 my $add = $LIB->_copy($z->{_m}); 20639f11ffb7Safresh1 20649f11ffb7Safresh1 if ($es eq '-') # < 0 2065b8851fccSafresh1 { 2066b46d8ef2Safresh1 $x->{_m} = $LIB->_lsft($x->{_m}, $e, 10); 2067e0680481Safresh1 ($x->{_e}, $x->{_es}) = $LIB -> _sadd($x->{_e}, $x->{_es}, $e, $es); 2068b46d8ef2Safresh1 } elsif (!$LIB->_is_zero($e)) # > 0 20699f11ffb7Safresh1 { 2070b46d8ef2Safresh1 $add = $LIB->_lsft($add, $e, 10); 20719f11ffb7Safresh1 } 20729f11ffb7Safresh1 # else: both e are the same, so just leave them 20739f11ffb7Safresh1 20749f11ffb7Safresh1 if ($x->{sign} eq $z->{sign}) { 20759f11ffb7Safresh1 # add 2076b46d8ef2Safresh1 $x->{_m} = $LIB->_add($x->{_m}, $add); 20779f11ffb7Safresh1 } else { 20789f11ffb7Safresh1 ($x->{_m}, $x->{sign}) = 2079e0680481Safresh1 $LIB -> _sadd($x->{_m}, $x->{sign}, $add, $z->{sign}); 20809f11ffb7Safresh1 } 20819f11ffb7Safresh1 20829f11ffb7Safresh1 # delete trailing zeros, then round 2083e0680481Safresh1 $x = $x->bnorm()->round(@r); 2084e0680481Safresh1 2085e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 2086e0680481Safresh1 if defined($downgrade) && ($x->is_int() || $x->is_inf() || $x->is_nan()); 2087e0680481Safresh1 return $x; 20889f11ffb7Safresh1} 20899f11ffb7Safresh1 20909f11ffb7Safresh1sub bdiv { 20919f11ffb7Safresh1 # (dividend: BFLOAT or num_str, divisor: BFLOAT or num_str) return 20929f11ffb7Safresh1 # (BFLOAT, BFLOAT) (quo, rem) or BFLOAT (only quo) 20939f11ffb7Safresh1 20949f11ffb7Safresh1 # set up parameters 2095e0680481Safresh1 my ($class, $x, $y, @r) = (ref($_[0]), @_); 20969f11ffb7Safresh1 # objectify is costly, so avoid it 20979f11ffb7Safresh1 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { 2098e0680481Safresh1 ($class, $x, $y, @r) = objectify(2, @_); 20999f11ffb7Safresh1 } 21009f11ffb7Safresh1 21019f11ffb7Safresh1 return $x if $x->modify('bdiv'); 21029f11ffb7Safresh1 21039f11ffb7Safresh1 my $wantarray = wantarray; # call only once 21049f11ffb7Safresh1 21059f11ffb7Safresh1 # At least one argument is NaN. This is handled the same way as in 21069f11ffb7Safresh1 # Math::BigInt -> bdiv(). 21079f11ffb7Safresh1 21089f11ffb7Safresh1 if ($x -> is_nan() || $y -> is_nan()) { 2109e0680481Safresh1 return $wantarray ? ($x -> bnan(@r), $class -> bnan(@r)) 2110e0680481Safresh1 : $x -> bnan(@r); 21119f11ffb7Safresh1 } 21129f11ffb7Safresh1 21139f11ffb7Safresh1 # Divide by zero and modulo zero. This is handled the same way as in 21149f11ffb7Safresh1 # Math::BigInt -> bdiv(). See the comment in the code for Math::BigInt -> 21159f11ffb7Safresh1 # bdiv() for further details. 21169f11ffb7Safresh1 21179f11ffb7Safresh1 if ($y -> is_zero()) { 21189f11ffb7Safresh1 my ($quo, $rem); 21199f11ffb7Safresh1 if ($wantarray) { 2120e0680481Safresh1 $rem = $x -> copy() -> round(@r); 2121e0680481Safresh1 $rem = $downgrade -> new($rem, @r) 2122e0680481Safresh1 if defined($downgrade) && $rem -> is_int(); 21239f11ffb7Safresh1 } 21249f11ffb7Safresh1 if ($x -> is_zero()) { 2125e0680481Safresh1 $quo = $x -> bnan(@r); 21269f11ffb7Safresh1 } else { 2127e0680481Safresh1 $quo = $x -> binf($x -> {sign}, @r); 21289f11ffb7Safresh1 } 21299f11ffb7Safresh1 return $wantarray ? ($quo, $rem) : $quo; 21309f11ffb7Safresh1 } 21319f11ffb7Safresh1 21329f11ffb7Safresh1 # Numerator (dividend) is +/-inf. This is handled the same way as in 21339f11ffb7Safresh1 # Math::BigInt -> bdiv(). See the comment in the code for Math::BigInt -> 21349f11ffb7Safresh1 # bdiv() for further details. 21359f11ffb7Safresh1 21369f11ffb7Safresh1 if ($x -> is_inf()) { 21379f11ffb7Safresh1 my ($quo, $rem); 2138e0680481Safresh1 $rem = $class -> bnan(@r) if $wantarray; 21399f11ffb7Safresh1 if ($y -> is_inf()) { 2140e0680481Safresh1 $quo = $x -> bnan(@r); 21419f11ffb7Safresh1 } else { 21429f11ffb7Safresh1 my $sign = $x -> bcmp(0) == $y -> bcmp(0) ? '+' : '-'; 2143e0680481Safresh1 $quo = $x -> binf($sign, @r); 21449f11ffb7Safresh1 } 21459f11ffb7Safresh1 return $wantarray ? ($quo, $rem) : $quo; 21469f11ffb7Safresh1 } 21479f11ffb7Safresh1 21489f11ffb7Safresh1 # Denominator (divisor) is +/-inf. This is handled the same way as in 21499f11ffb7Safresh1 # Math::BigInt -> bdiv(), with one exception: In scalar context, 21509f11ffb7Safresh1 # Math::BigFloat does true division (although rounded), not floored division 21519f11ffb7Safresh1 # (F-division), so a finite number divided by +/-inf is always zero. See the 21529f11ffb7Safresh1 # comment in the code for Math::BigInt -> bdiv() for further details. 21539f11ffb7Safresh1 21549f11ffb7Safresh1 if ($y -> is_inf()) { 21559f11ffb7Safresh1 my ($quo, $rem); 21569f11ffb7Safresh1 if ($wantarray) { 21579f11ffb7Safresh1 if ($x -> is_zero() || $x -> bcmp(0) == $y -> bcmp(0)) { 2158e0680481Safresh1 $rem = $x -> copy() -> round(@r); 2159e0680481Safresh1 $rem = $downgrade -> new($rem, @r) 2160e0680481Safresh1 if defined($downgrade) && $rem -> is_int(); 2161e0680481Safresh1 $quo = $x -> bzero(@r); 21629f11ffb7Safresh1 } else { 2163e0680481Safresh1 $rem = $class -> binf($y -> {sign}, @r); 2164e0680481Safresh1 $quo = $x -> bone('-', @r); 21659f11ffb7Safresh1 } 21669f11ffb7Safresh1 return ($quo, $rem); 21679f11ffb7Safresh1 } else { 21689f11ffb7Safresh1 if ($y -> is_inf()) { 21699f11ffb7Safresh1 if ($x -> is_nan() || $x -> is_inf()) { 2170e0680481Safresh1 return $x -> bnan(@r); 21719f11ffb7Safresh1 } else { 2172e0680481Safresh1 return $x -> bzero(@r); 21739f11ffb7Safresh1 } 21749f11ffb7Safresh1 } 21759f11ffb7Safresh1 } 21769f11ffb7Safresh1 } 21779f11ffb7Safresh1 21789f11ffb7Safresh1 # At this point, both the numerator and denominator are finite numbers, and 21799f11ffb7Safresh1 # the denominator (divisor) is non-zero. 21809f11ffb7Safresh1 21819f11ffb7Safresh1 # x == 0? 2182e0680481Safresh1 if ($x->is_zero()) { 2183e0680481Safresh1 my ($quo, $rem); 2184e0680481Safresh1 $quo = $x->round(@r); 2185e0680481Safresh1 $quo = $downgrade -> new($quo, @r) 2186e0680481Safresh1 if defined($downgrade) && $quo -> is_int(); 2187e0680481Safresh1 if ($wantarray) { 2188e0680481Safresh1 $rem = $class -> bzero(@r); 2189e0680481Safresh1 return $quo, $rem; 2190e0680481Safresh1 } 2191e0680481Safresh1 return $quo; 2192e0680481Safresh1 } 2193e0680481Safresh1 2194e0680481Safresh1 # Division might return a value that we can not represent exactly, so 2195e0680481Safresh1 # upgrade, if upgrading is enabled. 2196e0680481Safresh1 2197e0680481Safresh1 return $upgrade -> bdiv($x, $y, @r) 2198e0680481Safresh1 if defined($upgrade) && !wantarray && !$LIB -> _is_one($y -> {_m}); 21999f11ffb7Safresh1 22009f11ffb7Safresh1 # we need to limit the accuracy to protect against overflow 22019f11ffb7Safresh1 my $fallback = 0; 22029f11ffb7Safresh1 my (@params, $scale); 2203e0680481Safresh1 ($x, @params) = $x->_find_round_parameters($r[0], $r[1], $r[2], $y); 22049f11ffb7Safresh1 2205e0680481Safresh1 return $x -> round(@r) if $x->is_nan(); # error in _find_round_parameters? 22069f11ffb7Safresh1 22079f11ffb7Safresh1 # no rounding at all, so must use fallback 22089f11ffb7Safresh1 if (scalar @params == 0) { 22099f11ffb7Safresh1 # simulate old behaviour 22109f11ffb7Safresh1 $params[0] = $class->div_scale(); # and round to it as accuracy 22119f11ffb7Safresh1 $scale = $params[0]+4; # at least four more for proper round 2212e0680481Safresh1 $params[2] = $r[2]; # round mode by caller or undef 22139f11ffb7Safresh1 $fallback = 1; # to clear a/p afterwards 22149f11ffb7Safresh1 } else { 22159f11ffb7Safresh1 # the 4 below is empirical, and there might be cases where it is not 22169f11ffb7Safresh1 # enough... 22179f11ffb7Safresh1 $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined 22189f11ffb7Safresh1 } 22199f11ffb7Safresh1 22209f11ffb7Safresh1 my $rem; 22219f11ffb7Safresh1 $rem = $class -> bzero() if wantarray; 22229f11ffb7Safresh1 22239f11ffb7Safresh1 $y = $class->new($y) unless $y->isa('Math::BigFloat'); 22249f11ffb7Safresh1 2225e0680481Safresh1 my $lx = $LIB -> _len($x->{_m}); 2226e0680481Safresh1 my $ly = $LIB -> _len($y->{_m}); 22279f11ffb7Safresh1 $scale = $lx if $lx > $scale; 22289f11ffb7Safresh1 $scale = $ly if $ly > $scale; 22299f11ffb7Safresh1 my $diff = $ly - $lx; 22309f11ffb7Safresh1 $scale += $diff if $diff > 0; # if lx << ly, but not if ly << lx! 22319f11ffb7Safresh1 22329f11ffb7Safresh1 # check that $y is not 1 nor -1 and cache the result: 2233b46d8ef2Safresh1 my $y_not_one = !($LIB->_is_zero($y->{_e}) && $LIB->_is_one($y->{_m})); 22349f11ffb7Safresh1 22359f11ffb7Safresh1 # flipping the sign of $y will also flip the sign of $x for the special 22369f11ffb7Safresh1 # case of $x->bsub($x); so we can catch it below: 22379f11ffb7Safresh1 my $xsign = $x->{sign}; 22389f11ffb7Safresh1 $y->{sign} =~ tr/+-/-+/; 22399f11ffb7Safresh1 22409f11ffb7Safresh1 if ($xsign ne $x->{sign}) { 22419f11ffb7Safresh1 # special case of $x /= $x results in 1 2242e0680481Safresh1 $x = $x->bone(); # "fixes" also sign of $y, since $x is $y 22439f11ffb7Safresh1 } else { 22449f11ffb7Safresh1 # correct $y's sign again 22459f11ffb7Safresh1 $y->{sign} =~ tr/+-/-+/; 22469f11ffb7Safresh1 # continue with normal div code: 22479f11ffb7Safresh1 2248e0680481Safresh1 # make copy of $x in case of list context for later remainder 2249e0680481Safresh1 # calculation 22509f11ffb7Safresh1 if (wantarray && $y_not_one) { 22519f11ffb7Safresh1 $rem = $x->copy(); 22529f11ffb7Safresh1 } 22539f11ffb7Safresh1 22549f11ffb7Safresh1 $x->{sign} = $x->{sign} ne $y->sign() ? '-' : '+'; 22559f11ffb7Safresh1 22569f11ffb7Safresh1 # check for / +-1 (+/- 1E0) 22579f11ffb7Safresh1 if ($y_not_one) { 2258e0680481Safresh1 # promote Math::BigInt and its subclasses (except when already a 2259e0680481Safresh1 # Math::BigFloat) 22609f11ffb7Safresh1 $y = $class->new($y) unless $y->isa('Math::BigFloat'); 22619f11ffb7Safresh1 22629f11ffb7Safresh1 # calculate the result to $scale digits and then round it 22639f11ffb7Safresh1 # a * 10 ** b / c * 10 ** d => a/c * 10 ** (b-d) 2264b46d8ef2Safresh1 $x->{_m} = $LIB->_lsft($x->{_m}, $LIB->_new($scale), 10); 2265b46d8ef2Safresh1 $x->{_m} = $LIB->_div($x->{_m}, $y->{_m}); # a/c 22669f11ffb7Safresh1 22679f11ffb7Safresh1 # correct exponent of $x 2268e0680481Safresh1 ($x->{_e}, $x->{_es}) 2269e0680481Safresh1 = $LIB -> _ssub($x->{_e}, $x->{_es}, $y->{_e}, $y->{_es}); 22709f11ffb7Safresh1 # correct for 10**scale 2271e0680481Safresh1 ($x->{_e}, $x->{_es}) 2272e0680481Safresh1 = $LIB -> _ssub($x->{_e}, $x->{_es}, $LIB->_new($scale), '+'); 2273e0680481Safresh1 $x = $x->bnorm(); # remove trailing 0's 22749f11ffb7Safresh1 } 22759f11ffb7Safresh1 } # end else $x != $y 22769f11ffb7Safresh1 22779f11ffb7Safresh1 # shortcut to not run through _find_round_parameters again 22789f11ffb7Safresh1 if (defined $params[0]) { 2279*3d61058aSafresh1 $x->{accuracy} = undef; # clear before round 2280e0680481Safresh1 $x = $x->bround($params[0], $params[2]); # then round accordingly 22819f11ffb7Safresh1 } else { 2282*3d61058aSafresh1 $x->{precision} = undef; # clear before round 2283e0680481Safresh1 $x = $x->bfround($params[1], $params[2]); # then round accordingly 22849f11ffb7Safresh1 } 22859f11ffb7Safresh1 if ($fallback) { 22869f11ffb7Safresh1 # clear a/p after round, since user did not request it 2287*3d61058aSafresh1 $x->{accuracy} = undef; 2288*3d61058aSafresh1 $x->{precision} = undef; 22899f11ffb7Safresh1 } 22909f11ffb7Safresh1 22919f11ffb7Safresh1 if (wantarray) { 22929f11ffb7Safresh1 if ($y_not_one) { 2293e0680481Safresh1 $x = $x -> bfloor(); 2294e0680481Safresh1 $rem = $rem->bmod($y, @params); # copy already done 22959f11ffb7Safresh1 } 22969f11ffb7Safresh1 if ($fallback) { 22979f11ffb7Safresh1 # clear a/p after round, since user did not request it 2298*3d61058aSafresh1 $rem->{accuracy} = undef; 2299*3d61058aSafresh1 $rem->{precision} = undef; 23009f11ffb7Safresh1 } 2301e0680481Safresh1 $x = $downgrade -> new($x -> bdstr(), @r) 2302eac174f2Safresh1 if defined($downgrade) && $x -> is_int(); 2303e0680481Safresh1 $rem = $downgrade -> new($rem -> bdstr(), @r) 2304eac174f2Safresh1 if defined($downgrade) && $rem -> is_int(); 23059f11ffb7Safresh1 return ($x, $rem); 23069f11ffb7Safresh1 } 2307eac174f2Safresh1 2308e0680481Safresh1 $x = $downgrade -> new($x, @r) 2309e0680481Safresh1 if defined($downgrade) && $x -> is_int(); 2310e0680481Safresh1 $x; # rounding already done above 23119f11ffb7Safresh1} 23129f11ffb7Safresh1 23139f11ffb7Safresh1sub bmod { 23149f11ffb7Safresh1 # (dividend: BFLOAT or num_str, divisor: BFLOAT or num_str) return remainder 23159f11ffb7Safresh1 23169f11ffb7Safresh1 # set up parameters 2317e0680481Safresh1 my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 2318e0680481Safresh1 ? (ref($_[0]), @_) 2319e0680481Safresh1 : objectify(2, @_); 23209f11ffb7Safresh1 23219f11ffb7Safresh1 return $x if $x->modify('bmod'); 23229f11ffb7Safresh1 23239f11ffb7Safresh1 # At least one argument is NaN. This is handled the same way as in 23249f11ffb7Safresh1 # Math::BigInt -> bmod(). 23259f11ffb7Safresh1 2326e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); 23279f11ffb7Safresh1 23289f11ffb7Safresh1 # Modulo zero. This is handled the same way as in Math::BigInt -> bmod(). 23299f11ffb7Safresh1 23309f11ffb7Safresh1 if ($y -> is_zero()) { 2331e0680481Safresh1 return $x -> round(@r); 23329f11ffb7Safresh1 } 23339f11ffb7Safresh1 23349f11ffb7Safresh1 # Numerator (dividend) is +/-inf. This is handled the same way as in 23359f11ffb7Safresh1 # Math::BigInt -> bmod(). 23369f11ffb7Safresh1 23379f11ffb7Safresh1 if ($x -> is_inf()) { 2338e0680481Safresh1 return $x -> bnan(@r); 23399f11ffb7Safresh1 } 23409f11ffb7Safresh1 23419f11ffb7Safresh1 # Denominator (divisor) is +/-inf. This is handled the same way as in 23429f11ffb7Safresh1 # Math::BigInt -> bmod(). 23439f11ffb7Safresh1 23449f11ffb7Safresh1 if ($y -> is_inf()) { 23459f11ffb7Safresh1 if ($x -> is_zero() || $x -> bcmp(0) == $y -> bcmp(0)) { 2346e0680481Safresh1 return $x -> round(@r); 23479f11ffb7Safresh1 } else { 2348e0680481Safresh1 return $x -> binf($y -> sign(), @r); 23499f11ffb7Safresh1 } 23509f11ffb7Safresh1 } 23519f11ffb7Safresh1 2352e0680481Safresh1 return $x->bzero(@r) if $x->is_zero() 23539f11ffb7Safresh1 || ($x->is_int() && 23549f11ffb7Safresh1 # check that $y == +1 or $y == -1: 2355b46d8ef2Safresh1 ($LIB->_is_zero($y->{_e}) && $LIB->_is_one($y->{_m}))); 23569f11ffb7Safresh1 23579f11ffb7Safresh1 my $cmp = $x->bacmp($y); # equal or $x < $y? 23589f11ffb7Safresh1 if ($cmp == 0) { # $x == $y => result 0 2359e0680481Safresh1 return $x -> bzero(@r); 23609f11ffb7Safresh1 } 23619f11ffb7Safresh1 23629f11ffb7Safresh1 # only $y of the operands negative? 23639f11ffb7Safresh1 my $neg = $x->{sign} ne $y->{sign} ? 1 : 0; 23649f11ffb7Safresh1 23659f11ffb7Safresh1 $x->{sign} = $y->{sign}; # calc sign first 23669f11ffb7Safresh1 if ($cmp < 0 && $neg == 0) { # $x < $y => result $x 2367e0680481Safresh1 return $x -> round(@r); 23689f11ffb7Safresh1 } 23699f11ffb7Safresh1 2370b46d8ef2Safresh1 my $ym = $LIB->_copy($y->{_m}); 23719f11ffb7Safresh1 23729f11ffb7Safresh1 # 2e1 => 20 2373b46d8ef2Safresh1 $ym = $LIB->_lsft($ym, $y->{_e}, 10) 2374b46d8ef2Safresh1 if $y->{_es} eq '+' && !$LIB->_is_zero($y->{_e}); 23759f11ffb7Safresh1 23769f11ffb7Safresh1 # if $y has digits after dot 23779f11ffb7Safresh1 my $shifty = 0; # correct _e of $x by this 23789f11ffb7Safresh1 if ($y->{_es} eq '-') # has digits after dot 23799f11ffb7Safresh1 { 23809f11ffb7Safresh1 # 123 % 2.5 => 1230 % 25 => 5 => 0.5 2381b46d8ef2Safresh1 $shifty = $LIB->_num($y->{_e}); # no more digits after dot 2382e0680481Safresh1 # 123 => 1230, $y->{_m} is already 25 2383e0680481Safresh1 $x->{_m} = $LIB->_lsft($x->{_m}, $y->{_e}, 10); 23849f11ffb7Safresh1 } 23859f11ffb7Safresh1 # $ym is now mantissa of $y based on exponent 0 23869f11ffb7Safresh1 23879f11ffb7Safresh1 my $shiftx = 0; # correct _e of $x by this 23889f11ffb7Safresh1 if ($x->{_es} eq '-') # has digits after dot 23899f11ffb7Safresh1 { 23909f11ffb7Safresh1 # 123.4 % 20 => 1234 % 200 2391b46d8ef2Safresh1 $shiftx = $LIB->_num($x->{_e}); # no more digits after dot 2392b46d8ef2Safresh1 $ym = $LIB->_lsft($ym, $x->{_e}, 10); # 123 => 1230 23939f11ffb7Safresh1 } 23949f11ffb7Safresh1 # 123e1 % 20 => 1230 % 20 2395b46d8ef2Safresh1 if ($x->{_es} eq '+' && !$LIB->_is_zero($x->{_e})) { 2396b46d8ef2Safresh1 $x->{_m} = $LIB->_lsft($x->{_m}, $x->{_e}, 10); # es => '+' here 23979f11ffb7Safresh1 } 23989f11ffb7Safresh1 2399b46d8ef2Safresh1 $x->{_e} = $LIB->_new($shiftx); 2400b8851fccSafresh1 $x->{_es} = '+'; 24019f11ffb7Safresh1 $x->{_es} = '-' if $shiftx != 0 || $shifty != 0; 2402b46d8ef2Safresh1 $x->{_e} = $LIB->_add($x->{_e}, $LIB->_new($shifty)) if $shifty != 0; 24039f11ffb7Safresh1 24049f11ffb7Safresh1 # now mantissas are equalized, exponent of $x is adjusted, so calc result 24059f11ffb7Safresh1 2406b46d8ef2Safresh1 $x->{_m} = $LIB->_mod($x->{_m}, $ym); 24079f11ffb7Safresh1 2408b46d8ef2Safresh1 $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # fix sign for -0 2409e0680481Safresh1 $x = $x->bnorm(); 24109f11ffb7Safresh1 2411e0680481Safresh1 # if one of them negative => correct in place 2412e0680481Safresh1 if ($neg != 0 && ! $x -> is_zero()) { 24139f11ffb7Safresh1 my $r = $y - $x; 24149f11ffb7Safresh1 $x->{_m} = $r->{_m}; 24159f11ffb7Safresh1 $x->{_e} = $r->{_e}; 24169f11ffb7Safresh1 $x->{_es} = $r->{_es}; 2417b46d8ef2Safresh1 $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # fix sign for -0 2418e0680481Safresh1 $x = $x->bnorm(); 2419b8851fccSafresh1 } 2420b8851fccSafresh1 2421e0680481Safresh1 $x = $x->round($r[0], $r[1], $r[2], $y); 2422e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 2423e0680481Safresh1 if defined($downgrade) && ($x->is_int() || $x->is_inf() || $x->is_nan()); 2424e0680481Safresh1 return $x; 2425b8851fccSafresh1} 2426b8851fccSafresh1 24279f11ffb7Safresh1sub bmodpow { 24289f11ffb7Safresh1 # takes a very large number to a very large exponent in a given very 24299f11ffb7Safresh1 # large modulus, quickly, thanks to binary exponentiation. Supports 24309f11ffb7Safresh1 # negative exponents. 2431e0680481Safresh1 my ($class, $num, $exp, $mod, @r) 2432e0680481Safresh1 = ref($_[0]) && ref($_[0]) eq ref($_[1]) && ref($_[1]) eq ref($_[2]) 2433e0680481Safresh1 ? (ref($_[0]), @_) 2434e0680481Safresh1 : objectify(3, @_); 24359f11ffb7Safresh1 24369f11ffb7Safresh1 return $num if $num->modify('bmodpow'); 24379f11ffb7Safresh1 2438e0680481Safresh1 return $num -> bnan(@r) 2439e0680481Safresh1 if $mod->is_nan() || $exp->is_nan() || $mod->is_nan(); 2440e0680481Safresh1 24419f11ffb7Safresh1 # check modulus for valid values 2442e0680481Safresh1 return $num->bnan(@r) if $mod->{sign} ne '+' || $mod->is_zero(); 24439f11ffb7Safresh1 24449f11ffb7Safresh1 # check exponent for valid values 24459f11ffb7Safresh1 if ($exp->{sign} =~ /\w/) { 24469f11ffb7Safresh1 # i.e., if it's NaN, +inf, or -inf... 2447e0680481Safresh1 return $num->bnan(@r); 2448b8851fccSafresh1 } 2449b8851fccSafresh1 2450e0680481Safresh1 $num = $num->bmodinv($mod, @r) if $exp->{sign} eq '-'; 2451b8851fccSafresh1 24529f11ffb7Safresh1 # check num for valid values (also NaN if there was no inverse but $exp < 0) 2453e0680481Safresh1 return $num->bnan(@r) if $num->{sign} !~ /^[+-]$/; 2454b8851fccSafresh1 24559f11ffb7Safresh1 # $mod is positive, sign on $exp is ignored, result also positive 24569f11ffb7Safresh1 24579f11ffb7Safresh1 # XXX TODO: speed it up when all three numbers are integers 2458e0680481Safresh1 $num = $num->bpow($exp)->bmod($mod); 2459e0680481Safresh1 2460e0680481Safresh1 return $downgrade -> new($num -> bdstr(), @r) if defined($downgrade) 2461e0680481Safresh1 && ($num->is_int() || $num->is_inf() || $num->is_nan()); 2462e0680481Safresh1 return $num -> round(@r); 24639f11ffb7Safresh1} 24649f11ffb7Safresh1 24659f11ffb7Safresh1sub bpow { 24669f11ffb7Safresh1 # (BFLOAT or num_str, BFLOAT or num_str) return BFLOAT 24679f11ffb7Safresh1 # compute power of two numbers, second arg is used as integer 24689f11ffb7Safresh1 # modifies first argument 24699f11ffb7Safresh1 24709f11ffb7Safresh1 # set up parameters 24719f11ffb7Safresh1 my ($class, $x, $y, $a, $p, $r) = (ref($_[0]), @_); 24729f11ffb7Safresh1 # objectify is costly, so avoid it 24739f11ffb7Safresh1 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { 24749f11ffb7Safresh1 ($class, $x, $y, $a, $p, $r) = objectify(2, @_); 24759f11ffb7Safresh1 } 24769f11ffb7Safresh1 24779f11ffb7Safresh1 return $x if $x -> modify('bpow'); 24789f11ffb7Safresh1 2479b46d8ef2Safresh1 # $x and/or $y is a NaN 2480b46d8ef2Safresh1 return $x -> bnan() if $x -> is_nan() || $y -> is_nan(); 2481b46d8ef2Safresh1 2482b46d8ef2Safresh1 # $x and/or $y is a +/-Inf 2483b46d8ef2Safresh1 if ($x -> is_inf("-")) { 2484b46d8ef2Safresh1 return $x -> bzero() if $y -> is_negative(); 2485b46d8ef2Safresh1 return $x -> bnan() if $y -> is_zero(); 2486b46d8ef2Safresh1 return $x if $y -> is_odd(); 2487b46d8ef2Safresh1 return $x -> bneg(); 2488b46d8ef2Safresh1 } elsif ($x -> is_inf("+")) { 2489b46d8ef2Safresh1 return $x -> bzero() if $y -> is_negative(); 2490b46d8ef2Safresh1 return $x -> bnan() if $y -> is_zero(); 2491b46d8ef2Safresh1 return $x; 2492b46d8ef2Safresh1 } elsif ($y -> is_inf("-")) { 2493b46d8ef2Safresh1 return $x -> bnan() if $x -> is_one("-"); 2494b46d8ef2Safresh1 return $x -> binf("+") if $x > -1 && $x < 1; 2495b46d8ef2Safresh1 return $x -> bone() if $x -> is_one("+"); 2496b46d8ef2Safresh1 return $x -> bzero(); 2497b46d8ef2Safresh1 } elsif ($y -> is_inf("+")) { 2498b46d8ef2Safresh1 return $x -> bnan() if $x -> is_one("-"); 2499b46d8ef2Safresh1 return $x -> bzero() if $x > -1 && $x < 1; 2500b46d8ef2Safresh1 return $x -> bone() if $x -> is_one("+"); 2501b46d8ef2Safresh1 return $x -> binf("+"); 2502b46d8ef2Safresh1 } 2503b46d8ef2Safresh1 2504eac174f2Safresh1 if ($x -> is_zero()) { 2505eac174f2Safresh1 return $x -> bone() if $y -> is_zero(); 2506eac174f2Safresh1 return $x -> binf() if $y -> is_negative(); 2507eac174f2Safresh1 return $x; 2508eac174f2Safresh1 } 25099f11ffb7Safresh1 2510eac174f2Safresh1 # We don't support complex numbers, so upgrade or return NaN. 25119f11ffb7Safresh1 2512eac174f2Safresh1 if ($x -> is_negative() && !$y -> is_int()) { 2513e0680481Safresh1 return $upgrade -> bpow($x, $y, $a, $p, $r) if defined $upgrade; 2514eac174f2Safresh1 return $x -> bnan(); 2515eac174f2Safresh1 } 25169f11ffb7Safresh1 2517eac174f2Safresh1 if ($x -> is_one("+") || $y -> is_one()) { 2518eac174f2Safresh1 return $x; 2519eac174f2Safresh1 } 25209f11ffb7Safresh1 2521b46d8ef2Safresh1 if ($x -> is_one("-")) { 2522eac174f2Safresh1 return $x if $y -> is_odd(); 2523eac174f2Safresh1 return $x -> bneg(); 25249f11ffb7Safresh1 } 2525eac174f2Safresh1 2526eac174f2Safresh1 return $x -> _pow($y, $a, $p, $r) if !$y -> is_int(); 2527eac174f2Safresh1 2528eac174f2Safresh1 my $y1 = $y -> as_int()->{value}; # make MBI part 25299f11ffb7Safresh1 25309f11ffb7Safresh1 my $new_sign = '+'; 2531b46d8ef2Safresh1 $new_sign = $LIB -> _is_odd($y1) ? '-' : '+' if $x->{sign} ne '+'; 25329f11ffb7Safresh1 25339f11ffb7Safresh1 # calculate $x->{_m} ** $y and $x->{_e} * $y separately (faster) 2534b46d8ef2Safresh1 $x->{_m} = $LIB -> _pow($x->{_m}, $y1); 2535b46d8ef2Safresh1 $x->{_e} = $LIB -> _mul($x->{_e}, $y1); 25369f11ffb7Safresh1 25379f11ffb7Safresh1 $x->{sign} = $new_sign; 2538e0680481Safresh1 $x = $x -> bnorm(); 2539eac174f2Safresh1 2540eac174f2Safresh1 # x ** (-y) = 1 / (x ** y) 2541eac174f2Safresh1 25429f11ffb7Safresh1 if ($y->{sign} eq '-') { 25439f11ffb7Safresh1 # modify $x in place! 2544eac174f2Safresh1 my $z = $x -> copy(); 2545e0680481Safresh1 $x = $x -> bone(); 2546eac174f2Safresh1 # round in one go (might ignore y's A!) 2547eac174f2Safresh1 return scalar $x -> bdiv($z, $a, $p, $r); 25489f11ffb7Safresh1 } 2549eac174f2Safresh1 2550e0680481Safresh1 $x = $x -> round($a, $p, $r, $y); 2551e0680481Safresh1 2552e0680481Safresh1 return $downgrade -> new($x) 2553e0680481Safresh1 if defined($downgrade) && ($x->is_int() || $x->is_inf() || $x->is_nan()); 2554e0680481Safresh1 return $x; 25559f11ffb7Safresh1} 25569f11ffb7Safresh1 2557*3d61058aSafresh1sub binv { 2558*3d61058aSafresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 2559*3d61058aSafresh1 2560*3d61058aSafresh1 return $x if $x->modify('binv'); 2561*3d61058aSafresh1 2562*3d61058aSafresh1 my $inv = $class -> bdiv($class -> bone(), $x, @r); 2563*3d61058aSafresh1 2564*3d61058aSafresh1 return $downgrade -> new($inv, @r) if defined($downgrade) 2565*3d61058aSafresh1 && ($inv -> is_int() || $inv -> is_inf() || $inv -> is_nan()); 2566*3d61058aSafresh1 2567*3d61058aSafresh1 for my $key (qw/ sign _m _es _e /) { 2568*3d61058aSafresh1 $x -> {$key} = $inv -> {$key}; 2569*3d61058aSafresh1 } 2570*3d61058aSafresh1 2571*3d61058aSafresh1 $x; 2572*3d61058aSafresh1} 2573*3d61058aSafresh1 25749f11ffb7Safresh1sub blog { 25759f11ffb7Safresh1 # Return the logarithm of the operand. If a second operand is defined, that 25769f11ffb7Safresh1 # value is used as the base, otherwise the base is assumed to be Euler's 25779f11ffb7Safresh1 # constant. 25789f11ffb7Safresh1 2579e0680481Safresh1 my ($class, $x, $base, @r); 25809f11ffb7Safresh1 2581e0680481Safresh1 # Only objectify the base if it is defined, since an undefined base, as in 2582*3d61058aSafresh1 # $x->blog() or $x->blog(undef) signals that the base is Euler's number = 2583*3d61058aSafresh1 # 2.718281828... 25849f11ffb7Safresh1 25859f11ffb7Safresh1 if (!ref($_[0]) && $_[0] =~ /^[A-Za-z]|::/) { 25869f11ffb7Safresh1 # E.g., Math::BigFloat->blog(256, 2) 2587e0680481Safresh1 ($class, $x, $base, @r) = 25889f11ffb7Safresh1 defined $_[2] ? objectify(2, @_) : objectify(1, @_); 25899f11ffb7Safresh1 } else { 2590*3d61058aSafresh1 # E.g., $x->blog(2) or the deprecated Math::BigFloat::blog(256, 2) 2591e0680481Safresh1 ($class, $x, $base, @r) = 25929f11ffb7Safresh1 defined $_[1] ? objectify(2, @_) : objectify(1, @_); 25939f11ffb7Safresh1 } 2594b8851fccSafresh1 2595b8851fccSafresh1 return $x if $x->modify('blog'); 2596b8851fccSafresh1 2597*3d61058aSafresh1 # Handle all exception cases and all trivial cases. I have used Wolfram 2598*3d61058aSafresh1 # Alpha (http://www.wolframalpha.com) as the reference for these cases. 2599*3d61058aSafresh1 2600e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan(); 2601e0680481Safresh1 2602*3d61058aSafresh1 if (defined $base) { 2603*3d61058aSafresh1 $base = $class -> new($base) 2604*3d61058aSafresh1 unless defined(blessed($base)) && $base -> isa(__PACKAGE__); 2605*3d61058aSafresh1 if ($base -> is_nan() || $base -> is_one()) { 2606*3d61058aSafresh1 return $x -> bnan(@r); 2607*3d61058aSafresh1 } elsif ($base -> is_inf() || $base -> is_zero()) { 2608*3d61058aSafresh1 return $x -> bnan(@r) if $x -> is_inf() || $x -> is_zero(); 2609*3d61058aSafresh1 return $x -> bzero(@r); 2610*3d61058aSafresh1 } elsif ($base -> is_negative()) { # -inf < base < 0 2611*3d61058aSafresh1 return $x -> bzero(@r) if $x -> is_one(); # x = 1 2612*3d61058aSafresh1 return $x -> bone('+', @r) if $x == $base; # x = base 2613*3d61058aSafresh1 # we can't handle these cases, so upgrade, if we can 2614*3d61058aSafresh1 return $upgrade -> blog($x, $base, @r) if defined $upgrade; 2615*3d61058aSafresh1 return $x -> bnan(@r); 2616*3d61058aSafresh1 } 2617*3d61058aSafresh1 return $x -> bone(@r) if $x == $base; # 0 < base && 0 < x < inf 2618*3d61058aSafresh1 } 2619*3d61058aSafresh1 2620*3d61058aSafresh1 if ($x -> is_inf()) { # x = +/-inf 2621*3d61058aSafresh1 my $sign = defined($base) && $base < 1 ? '-' : '+'; 2622*3d61058aSafresh1 return $x -> binf($sign, @r); 2623*3d61058aSafresh1 } elsif ($x -> is_neg()) { # -inf < x < 0 2624*3d61058aSafresh1 return $upgrade -> blog($x, $base, @r) if defined $upgrade; 2625*3d61058aSafresh1 return $x -> bnan(@r); 2626*3d61058aSafresh1 } elsif ($x -> is_one()) { # x = 1 2627*3d61058aSafresh1 return $x -> bzero(@r); 2628*3d61058aSafresh1 } elsif ($x -> is_zero()) { # x = 0 2629*3d61058aSafresh1 my $sign = defined($base) && $base < 1 ? '+' : '-'; 2630*3d61058aSafresh1 return $x -> binf($sign, @r); 2631*3d61058aSafresh1 } 2632b8851fccSafresh1 2633b8851fccSafresh1 # we need to limit the accuracy to protect against overflow 2634b8851fccSafresh1 my $fallback = 0; 2635b8851fccSafresh1 my ($scale, @params); 2636e0680481Safresh1 ($x, @params) = $x->_find_round_parameters(@r); 2637b8851fccSafresh1 2638b8851fccSafresh1 # no rounding at all, so must use fallback 26399f11ffb7Safresh1 if (scalar @params == 0) { 2640b8851fccSafresh1 # simulate old behaviour 26419f11ffb7Safresh1 $params[0] = $class->div_scale(); # and round to it as accuracy 2642b8851fccSafresh1 $params[1] = undef; # P = undef 2643b8851fccSafresh1 $scale = $params[0]+4; # at least four more for proper round 2644e0680481Safresh1 $params[2] = $r[2]; # round mode by caller or undef 2645b8851fccSafresh1 $fallback = 1; # to clear a/p afterwards 26469f11ffb7Safresh1 } else { 2647b8851fccSafresh1 # the 4 below is empirical, and there might be cases where it is not 2648b8851fccSafresh1 # enough... 2649b8851fccSafresh1 $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined 2650b8851fccSafresh1 } 2651b8851fccSafresh1 2652*3d61058aSafresh1 # When user set globals, they would interfere with our calculation, so 2653*3d61058aSafresh1 # disable them and later re-enable them. 2654*3d61058aSafresh1 2655*3d61058aSafresh1 my $ab = $class -> accuracy(); 2656*3d61058aSafresh1 my $pb = $class -> precision(); 2657*3d61058aSafresh1 $class -> accuracy(undef); 2658*3d61058aSafresh1 $class -> precision(undef); 2659*3d61058aSafresh1 2660*3d61058aSafresh1 # Disabling upgrading and downgrading is no longer necessary to avoid an 2661*3d61058aSafresh1 # infinite recursion, but it avoids unnecessary upgrading and downgrading in 2662*3d61058aSafresh1 # the intermediate computations. 2663*3d61058aSafresh1 2664*3d61058aSafresh1 my $upg = $class -> upgrade(); 2665*3d61058aSafresh1 my $dng = $class -> downgrade(); 2666*3d61058aSafresh1 $class -> upgrade(undef); 2667*3d61058aSafresh1 $class -> downgrade(undef); 2668*3d61058aSafresh1 2669*3d61058aSafresh1 # We also need to disable any set A or P on $x (_find_round_parameters took 2670*3d61058aSafresh1 # them already into account), since these would interfere, too. 2671*3d61058aSafresh1 2672*3d61058aSafresh1 $x->{accuracy} = undef; 2673*3d61058aSafresh1 $x->{precision} = undef; 2674*3d61058aSafresh1 2675b8851fccSafresh1 my $done = 0; 2676b8851fccSafresh1 2677*3d61058aSafresh1 # If both $x and $base are integers, try to calculate an integer result 2678*3d61058aSafresh1 # first. This is very fast, and if the exact result was found, we are done. 2679b46d8ef2Safresh1 2680e0680481Safresh1 if (defined($base) && $base -> is_int() && $x -> is_int()) { 2681e0680481Safresh1 my $x_lib = $LIB -> _new($x -> bdstr()); 2682e0680481Safresh1 my $b_lib = $LIB -> _new($base -> bdstr()); 2683e0680481Safresh1 ($x_lib, my $exact) = $LIB -> _log_int($x_lib, $b_lib); 2684e0680481Safresh1 if ($exact) { 2685e0680481Safresh1 $x->{_m} = $x_lib; 2686e0680481Safresh1 $x->{_e} = $LIB -> _zero(); 2687e0680481Safresh1 $x = $x -> bnorm(); 2688b8851fccSafresh1 $done = 1; 2689b8851fccSafresh1 } 2690b8851fccSafresh1 } 2691b8851fccSafresh1 2692*3d61058aSafresh1 # If the integer result was not accurate, compute the natural logarithm 2693*3d61058aSafresh1 # log($x) (using reduction by 10 and possibly also by 2), and if a 2694*3d61058aSafresh1 # different base was requested, convert the result with log($x)/log($base). 2695*3d61058aSafresh1 2696e0680481Safresh1 unless ($done) { 2697e0680481Safresh1 $x = $x -> _log_10($scale); 26989f11ffb7Safresh1 if (defined $base) { 2699b46d8ef2Safresh1 # log_b(x) = ln(x) / ln(b), so compute ln(b) 2700b46d8ef2Safresh1 my $base_log_e = $base -> copy() -> _log_10($scale); 2701e0680481Safresh1 $x = $x -> bdiv($base_log_e, $scale); 2702b8851fccSafresh1 } 2703b8851fccSafresh1 } 2704b8851fccSafresh1 2705b8851fccSafresh1 # shortcut to not run through _find_round_parameters again 2706*3d61058aSafresh1 27079f11ffb7Safresh1 if (defined $params[0]) { 2708e0680481Safresh1 $x = $x -> bround($params[0], $params[2]); # then round accordingly 27099f11ffb7Safresh1 } else { 2710e0680481Safresh1 $x = $x -> bfround($params[1], $params[2]); # then round accordingly 2711b8851fccSafresh1 } 27129f11ffb7Safresh1 if ($fallback) { 2713b8851fccSafresh1 # clear a/p after round, since user did not request it 2714*3d61058aSafresh1 $x->{accuracy} = undef; 2715*3d61058aSafresh1 $x->{precision} = undef; 2716b8851fccSafresh1 } 2717*3d61058aSafresh1 2718*3d61058aSafresh1 # Restore globals. We need to do it like this, because setting one 2719*3d61058aSafresh1 # undefines the other. 2720*3d61058aSafresh1 2721*3d61058aSafresh1 if (defined $ab) { 2722*3d61058aSafresh1 $class -> accuracy($ab); 2723*3d61058aSafresh1 } else { 2724*3d61058aSafresh1 $class -> precision($pb); 2725*3d61058aSafresh1 } 2726*3d61058aSafresh1 2727*3d61058aSafresh1 $class -> upgrade($upg); 2728*3d61058aSafresh1 $class -> downgrade($dng); 2729b8851fccSafresh1 2730e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 2731e0680481Safresh1 if defined($downgrade) && $x -> is_int(); 2732e0680481Safresh1 return $x; 2733b8851fccSafresh1} 2734b8851fccSafresh1 27359f11ffb7Safresh1sub bexp { 2736b8851fccSafresh1 # Calculate e ** X (Euler's number to the power of X) 2737e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 2738b8851fccSafresh1 2739b8851fccSafresh1 return $x if $x -> modify('bexp'); 2740b8851fccSafresh1 2741e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan(); 2742e0680481Safresh1 return $x -> binf(@r) if $x->{sign} eq '+inf'; 2743e0680481Safresh1 return $x -> bzero(@r) if $x->{sign} eq '-inf'; 2744b8851fccSafresh1 2745*3d61058aSafresh1 # Get the rounding parameters, if any. 2746*3d61058aSafresh1 2747b8851fccSafresh1 my $fallback = 0; 2748b8851fccSafresh1 my ($scale, @params); 2749e0680481Safresh1 ($x, @params) = $x -> _find_round_parameters(@r); 2750b8851fccSafresh1 2751*3d61058aSafresh1 # Error in _find_round_parameters? 2752*3d61058aSafresh1 2753e0680481Safresh1 return $x -> bnan(@r) if $x->{sign} eq 'NaN'; 2754b8851fccSafresh1 2755*3d61058aSafresh1 return $x -> bone(@r) if $x -> is_zero(); 2756*3d61058aSafresh1 2757*3d61058aSafresh1 # If no rounding parameters are give, use fallback. 2758*3d61058aSafresh1 2759*3d61058aSafresh1 if (!@params) { 2760*3d61058aSafresh1 $params[0] = $class -> div_scale(); # fallback accuracy 2761*3d61058aSafresh1 $params[1] = undef; # no precision 2762*3d61058aSafresh1 $params[2] = $r[2]; # rounding mode 2763*3d61058aSafresh1 $scale = $params[0]; 2764b8851fccSafresh1 $fallback = 1; # to clear a/p afterwards 27659f11ffb7Safresh1 } else { 2766*3d61058aSafresh1 if (defined($params[0])) { 2767*3d61058aSafresh1 $scale = $params[0]; 2768*3d61058aSafresh1 } else { 2769*3d61058aSafresh1 # We perform the computations below using accuracy only, not 2770*3d61058aSafresh1 # precision, so when precision is given, we need to "convert" this 2771*3d61058aSafresh1 # to accuracy. To do that, we need to know, at least approximately, 2772*3d61058aSafresh1 # how many digits there will be in the final result. 2773*3d61058aSafresh1 # 2774*3d61058aSafresh1 # log10(exp($x)) = log(exp($x)) / log(10) = $x / log(10) 2775*3d61058aSafresh1 2776*3d61058aSafresh1 #$scale = 1 + int(log($ms) / log(10) + $es) - $params[1]; 2777*3d61058aSafresh1 my $ndig = $x -> numify() / log(10); 2778*3d61058aSafresh1 $scale = 1 + int($ndig) - $params[1]; 2779*3d61058aSafresh1 } 2780b8851fccSafresh1 } 2781b8851fccSafresh1 2782*3d61058aSafresh1 # Add extra digits to reduce the consequence of round-off errors in the 2783*3d61058aSafresh1 # intermediate computations. 2784*3d61058aSafresh1 2785*3d61058aSafresh1 $scale += 4; 2786b8851fccSafresh1 27879f11ffb7Safresh1 if (!$x -> isa('Math::BigFloat')) { 2788b8851fccSafresh1 $x = Math::BigFloat -> new($x); 27899f11ffb7Safresh1 $class = ref($x); 2790b8851fccSafresh1 } 2791b8851fccSafresh1 2792*3d61058aSafresh1 # When user set globals, they would interfere with our calculation, so 2793*3d61058aSafresh1 # disable them and later re-enable them. 2794*3d61058aSafresh1 2795*3d61058aSafresh1 my $ab = $class -> accuracy(); 2796*3d61058aSafresh1 my $pb = $class -> precision(); 2797*3d61058aSafresh1 $class -> accuracy(undef); 2798*3d61058aSafresh1 $class -> precision(undef); 2799e0680481Safresh1 2800e0680481Safresh1 # Disabling upgrading and downgrading is no longer necessary to avoid an 2801e0680481Safresh1 # infinite recursion, but it avoids unnecessary upgrading and downgrading in 2802e0680481Safresh1 # the intermediate computations. 2803e0680481Safresh1 2804*3d61058aSafresh1 my $upg = $class -> upgrade(); 2805*3d61058aSafresh1 my $dng = $class -> downgrade(); 2806*3d61058aSafresh1 $class -> upgrade(undef); 2807*3d61058aSafresh1 $class -> downgrade(undef); 2808b8851fccSafresh1 2809*3d61058aSafresh1 # We also need to disable any set A or P on $x (_find_round_parameters took 2810*3d61058aSafresh1 # them already into account), since these would interfere, too. 2811*3d61058aSafresh1 2812*3d61058aSafresh1 $x->{accuracy} = undef; 2813*3d61058aSafresh1 $x->{precision} = undef; 2814*3d61058aSafresh1 2815*3d61058aSafresh1 my $x_orig = $x -> copy(); 2816b8851fccSafresh1 2817b8851fccSafresh1 # We use the following Taylor series: 2818b8851fccSafresh1 2819b8851fccSafresh1 # x x^2 x^3 x^4 2820b8851fccSafresh1 # e = 1 + --- + --- + --- + --- ... 2821b8851fccSafresh1 # 1! 2! 3! 4! 2822b8851fccSafresh1 2823b8851fccSafresh1 # The difference for each term is X and N, which would result in: 2824b8851fccSafresh1 # 2 copy, 2 mul, 2 add, 1 inc, 1 div operations per term 2825b8851fccSafresh1 2826b8851fccSafresh1 # But it is faster to compute exp(1) and then raising it to the 2827b8851fccSafresh1 # given power, esp. if $x is really big and an integer because: 2828b8851fccSafresh1 2829b8851fccSafresh1 # * The numerator is always 1, making the computation faster 2830b8851fccSafresh1 # * the series converges faster in the case of x == 1 2831b8851fccSafresh1 # * We can also easily check when we have reached our limit: when the 2832b8851fccSafresh1 # term to be added is smaller than "1E$scale", we can stop - f.i. 2833b8851fccSafresh1 # scale == 5, and we have 1/40320, then we stop since 1/40320 < 1E-5. 2834b8851fccSafresh1 # * we can compute the *exact* result by simulating bigrat math: 2835b8851fccSafresh1 2836b8851fccSafresh1 # 1 1 gcd(3, 4) = 1 1*24 + 1*6 5 2837b8851fccSafresh1 # - + - = ---------- = -- 2838b8851fccSafresh1 # 6 24 6*24 24 2839b8851fccSafresh1 2840b8851fccSafresh1 # We do not compute the gcd() here, but simple do: 2841b8851fccSafresh1 # 1 1 1*24 + 1*6 30 2842b8851fccSafresh1 # - + - = --------- = -- 2843b8851fccSafresh1 # 6 24 6*24 144 2844b8851fccSafresh1 2845b8851fccSafresh1 # In general: 2846b8851fccSafresh1 # a c a*d + c*b and note that c is always 1 and d = (b*f) 2847b8851fccSafresh1 # - + - = --------- 2848b8851fccSafresh1 # b d b*d 2849b8851fccSafresh1 2850b8851fccSafresh1 # This leads to: which can be reduced by b to: 2851b8851fccSafresh1 # a 1 a*b*f + b a*f + 1 2852b8851fccSafresh1 # - + - = --------- = ------- 2853b8851fccSafresh1 # b b*f b*b*f b*f 2854b8851fccSafresh1 2855b8851fccSafresh1 # The first terms in the series are: 2856b8851fccSafresh1 2857b8851fccSafresh1 # 1 1 1 1 1 1 1 1 13700 2858b8851fccSafresh1 # -- + -- + -- + -- + -- + --- + --- + ---- = ----- 2859b8851fccSafresh1 # 1 1 2 6 24 120 720 5040 5040 2860b8851fccSafresh1 2861b46d8ef2Safresh1 # Note that we cannot simply reduce 13700/5040 to 685/252, but must keep 2862b46d8ef2Safresh1 # the numerator and the denominator! 2863b8851fccSafresh1 28649f11ffb7Safresh1 if ($scale <= 75) { 2865b8851fccSafresh1 # set $x directly from a cached string form 2866b46d8ef2Safresh1 $x->{_m} = $LIB->_new("2718281828459045235360287471352662497757" . 2867b46d8ef2Safresh1 "2470936999595749669676277240766303535476"); 2868b8851fccSafresh1 $x->{sign} = '+'; 2869b8851fccSafresh1 $x->{_es} = '-'; 2870b46d8ef2Safresh1 $x->{_e} = $LIB->_new(79); 28719f11ffb7Safresh1 } else { 2872b8851fccSafresh1 # compute A and B so that e = A / B. 2873b8851fccSafresh1 2874e0680481Safresh1 # After some terms we end up with this, so we use it as a starting 2875e0680481Safresh1 # point: 2876b46d8ef2Safresh1 my $A = $LIB->_new("9093339520860578540197197" . 2877b46d8ef2Safresh1 "0164779391644753259799242"); 2878b46d8ef2Safresh1 my $F = $LIB->_new(42); 28799f11ffb7Safresh1 my $step = 42; 2880b8851fccSafresh1 2881*3d61058aSafresh1 # Compute number of steps needed to get $A and $B sufficiently large. 2882*3d61058aSafresh1 2883b8851fccSafresh1 my $steps = _len_to_steps($scale - 4); 2884b8851fccSafresh1 # print STDERR "# Doing $steps steps for ", $scale-4, " digits\n"; 2885*3d61058aSafresh1 28869f11ffb7Safresh1 while ($step++ <= $steps) { 2887b8851fccSafresh1 # calculate $a * $f + 1 2888b46d8ef2Safresh1 $A = $LIB -> _mul($A, $F); 2889b46d8ef2Safresh1 $A = $LIB -> _inc($A); 2890b8851fccSafresh1 # increment f 2891b46d8ef2Safresh1 $F = $LIB -> _inc($F); 2892b8851fccSafresh1 } 2893e0680481Safresh1 2894e0680481Safresh1 # Compute $B as factorial of $steps (this is faster than doing it 2895e0680481Safresh1 # manually) 2896b46d8ef2Safresh1 my $B = $LIB->_fac($LIB->_new($steps)); 2897b8851fccSafresh1 2898b46d8ef2Safresh1 # print "A ", $LIB->_str($A), "\nB ", $LIB->_str($B), "\n"; 2899b8851fccSafresh1 2900b8851fccSafresh1 # compute A/B with $scale digits in the result (truncate, not round) 2901b46d8ef2Safresh1 $A = $LIB->_lsft($A, $LIB->_new($scale), 10); 2902b46d8ef2Safresh1 $A = $LIB->_div($A, $B); 2903b8851fccSafresh1 2904b8851fccSafresh1 $x->{_m} = $A; 2905b8851fccSafresh1 $x->{sign} = '+'; 2906b8851fccSafresh1 $x->{_es} = '-'; 2907b46d8ef2Safresh1 $x->{_e} = $LIB->_new($scale); 2908b8851fccSafresh1 } 2909b8851fccSafresh1 2910*3d61058aSafresh1 # Now $x contains now an estimate of e, with some additional digits. 2911*3d61058aSafresh1 2912*3d61058aSafresh1 if ($x_orig -> is_one()) { 2913*3d61058aSafresh1 2914b8851fccSafresh1 # else just round the already computed result 2915*3d61058aSafresh1 2916*3d61058aSafresh1 $x->{accuracy} = undef; 2917*3d61058aSafresh1 $x->{precision} = undef; 2918*3d61058aSafresh1 2919b8851fccSafresh1 # shortcut to not run through _find_round_parameters again 2920*3d61058aSafresh1 29219f11ffb7Safresh1 if (defined $params[0]) { 2922e0680481Safresh1 $x = $x -> bround($params[0], $params[2]); # then round accordingly 29239f11ffb7Safresh1 } else { 2924e0680481Safresh1 $x = $x -> bfround($params[1], $params[2]); # then round accordingly 2925b8851fccSafresh1 } 2926*3d61058aSafresh1 2927*3d61058aSafresh1 } else { 2928*3d61058aSafresh1 2929*3d61058aSafresh1 # Use the fact exp(x) = exp(x/n)**n. In our case, n = 2**i for some 2930*3d61058aSafresh1 # integer i. We use this to compute exp(y) where y = x / (2**i) and 2931*3d61058aSafresh1 # 1 <= |y| < 2. 2932*3d61058aSafresh1 # 2933*3d61058aSafresh1 # The code below is similar to the code found in to_ieee754(). 2934*3d61058aSafresh1 2935*3d61058aSafresh1 # We need to find the base 2 exponent. First make an estimate of the 2936*3d61058aSafresh1 # base 2 exponent, before adjusting it below. We could skip this 2937*3d61058aSafresh1 # estimation and go straight to the while-loops below, but the loops 2938*3d61058aSafresh1 # are slow, especially when the final exponent is far from zero and 2939*3d61058aSafresh1 # even more so if the number of digits is large. This initial 2940*3d61058aSafresh1 # estimation speeds up the computation dramatically. 2941*3d61058aSafresh1 # 2942*3d61058aSafresh1 # log2($m * 10**$e) = log10($m + 10**$e) * log(10)/log(2) 2943*3d61058aSafresh1 # = (log10($m) + $e) * log(10)/log(2) 2944*3d61058aSafresh1 # = (log($m)/log(10) + $e) * log(10)/log(2) 2945*3d61058aSafresh1 2946*3d61058aSafresh1 my ($m, $e) = $x_orig -> nparts(); 2947*3d61058aSafresh1 my $ms = $m -> numify(); 2948*3d61058aSafresh1 my $es = $e -> numify(); 2949*3d61058aSafresh1 2950*3d61058aSafresh1 # We start off by initializing the exponent to zero and the mantissa to 2951*3d61058aSafresh1 # the input value. Then we increase the mantissa and decrease the 2952*3d61058aSafresh1 # exponent, or vice versa, until the mantissa is in the desired range 2953*3d61058aSafresh1 # or we hit one of the limits for the exponent. 2954*3d61058aSafresh1 2955*3d61058aSafresh1 my $mant = $x_orig -> copy() -> babs(); 2956*3d61058aSafresh1 my $expo; 2957*3d61058aSafresh1 2958*3d61058aSafresh1 my $one = $class -> bone(); 2959*3d61058aSafresh1 my $two = $class -> new("2"); 2960*3d61058aSafresh1 my $half = $class -> new("0.5"); 2961*3d61058aSafresh1 2962*3d61058aSafresh1 my $expo_est = (log(abs($ms))/log(10) + $es) * log(10)/log(2); 2963*3d61058aSafresh1 $expo_est = int($expo_est); 2964*3d61058aSafresh1 2965*3d61058aSafresh1 # Don't multiply by a number raised to a negative exponent. This will 2966*3d61058aSafresh1 # cause a division, whose result is truncated to some fixed number of 2967*3d61058aSafresh1 # digits. Instead, multiply by the inverse number raised to a positive 2968*3d61058aSafresh1 # exponent. 2969*3d61058aSafresh1 2970*3d61058aSafresh1 $expo = $class -> new($expo_est); 2971*3d61058aSafresh1 if ($expo_est > 0) { 2972*3d61058aSafresh1 $mant = $mant -> bmul($half -> copy() -> bpow($expo)); 2973*3d61058aSafresh1 } elsif ($expo_est < 0) { 2974*3d61058aSafresh1 my $expo_abs = $expo -> copy() -> bneg(); 2975*3d61058aSafresh1 $mant = $mant -> bmul($two -> copy() -> bpow($expo_abs)); 2976b8851fccSafresh1 } 2977*3d61058aSafresh1 2978*3d61058aSafresh1 # Final adjustment of the estimate above. 2979*3d61058aSafresh1 2980*3d61058aSafresh1 while ($mant -> bcmp($two) >= 0) { # $mant <= $two 2981*3d61058aSafresh1 $mant = $mant -> bmul($half); 2982*3d61058aSafresh1 $expo = $expo -> binc(); 2983*3d61058aSafresh1 } 2984*3d61058aSafresh1 2985*3d61058aSafresh1 while ($mant -> bcmp($one) < 0) { # $mant > $one 2986*3d61058aSafresh1 $mant = $mant -> bmul($two); 2987*3d61058aSafresh1 $expo = $expo -> bdec(); 2988*3d61058aSafresh1 } 2989*3d61058aSafresh1 2990*3d61058aSafresh1 # Because of the upscaling, we need some additional digits. 2991*3d61058aSafresh1 2992*3d61058aSafresh1 my $rescale = int($scale + abs($expo) * log(2) / log(10) + 1); 2993*3d61058aSafresh1 $rescale = 4 if $rescale < 4; 2994*3d61058aSafresh1 2995*3d61058aSafresh1 $x = $x -> bpow($mant, $rescale); 2996*3d61058aSafresh1 my $pow2 = $two -> bpow($expo, $rescale); 2997*3d61058aSafresh1 $pow2 -> bneg() if $x_orig -> is_negative(); 2998*3d61058aSafresh1 2999*3d61058aSafresh1 # The bpow() below fails with the GMP and GMPz libraries if abs($pow2) 3000*3d61058aSafresh1 # >= 2**30 = 1073741824. With the Pari library, it fails already when 3001*3d61058aSafresh1 # abs($pow) >= 2**13 = 8192. With the Calc library, it is rediculously 3002*3d61058aSafresh1 # slow when abs($pow2) is large. Fixme? 3003*3d61058aSafresh1 3004*3d61058aSafresh1 croak "cannot compute bexp(); input value is too large" 3005*3d61058aSafresh1 if $pow2 -> copy() -> babs() -> bcmp("1073741824") >= 0; 3006*3d61058aSafresh1 3007*3d61058aSafresh1 $x = $x -> bpow($pow2, $rescale); 3008*3d61058aSafresh1 3009*3d61058aSafresh1 # Rounding parameters given as arguments currently don't override 3010*3d61058aSafresh1 # instance variables, so accuracy (which is set in the computations 3011*3d61058aSafresh1 # above) must be undefined before rounding. Fixme. 3012*3d61058aSafresh1 3013*3d61058aSafresh1 $x->{accuracy} = undef; 3014*3d61058aSafresh1 $x -> round(@params); 3015*3d61058aSafresh1 } 3016*3d61058aSafresh1 30179f11ffb7Safresh1 if ($fallback) { 3018b8851fccSafresh1 # clear a/p after round, since user did not request it 3019*3d61058aSafresh1 $x->{accuracy} = undef; 3020*3d61058aSafresh1 $x->{precision} = undef; 3021b8851fccSafresh1 } 3022b8851fccSafresh1 3023*3d61058aSafresh1 # Restore globals. We need to do it like this, because setting one 3024*3d61058aSafresh1 # undefines the other. 3025*3d61058aSafresh1 3026*3d61058aSafresh1 if (defined $ab) { 3027*3d61058aSafresh1 $class -> accuracy($ab); 3028*3d61058aSafresh1 } else { 3029*3d61058aSafresh1 $class -> precision($pb); 3030*3d61058aSafresh1 } 3031*3d61058aSafresh1 3032*3d61058aSafresh1 $class -> upgrade($upg); 3033*3d61058aSafresh1 $class -> downgrade($dng); 3034*3d61058aSafresh1 3035*3d61058aSafresh1 # If downgrading, remember to preserve the relevant instance parameters. 3036*3d61058aSafresh1 # There should be a more elegant way to do this. Fixme. 3037*3d61058aSafresh1 3038*3d61058aSafresh1 if ($downgrade && $x -> is_int()) { 3039*3d61058aSafresh1 @r = ($x->{accuracy}, $x->{_r}); 3040*3d61058aSafresh1 my $tmp = $downgrade -> new($x, @r); 3041*3d61058aSafresh1 %$x = %$tmp; 3042*3d61058aSafresh1 return bless $x, $downgrade; 3043*3d61058aSafresh1 } 3044*3d61058aSafresh1 3045e0680481Safresh1 $x; 3046b8851fccSafresh1} 3047b8851fccSafresh1 3048*3d61058aSafresh1sub bilog2 { 3049*3d61058aSafresh1 croak "Method ", (caller(0))[3], "() not implemented yet"; 3050*3d61058aSafresh1} 3051*3d61058aSafresh1 3052*3d61058aSafresh1sub bilog10 { 3053*3d61058aSafresh1 croak "Method ", (caller(0))[3], "() not implemented yet"; 3054*3d61058aSafresh1} 3055*3d61058aSafresh1 3056*3d61058aSafresh1sub bclog2 { 3057*3d61058aSafresh1 croak "Method ", (caller(0))[3], "() not implemented yet"; 3058*3d61058aSafresh1} 3059*3d61058aSafresh1 3060*3d61058aSafresh1sub bclog10 { 3061*3d61058aSafresh1 croak "Method ", (caller(0))[3], "() not implemented yet"; 3062*3d61058aSafresh1} 3063*3d61058aSafresh1 30649f11ffb7Safresh1sub bnok { 30659f11ffb7Safresh1 # Calculate n over k (binomial coefficient or "choose" function) as integer. 30669f11ffb7Safresh1 # set up parameters 3067e0680481Safresh1 my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 3068e0680481Safresh1 ? (ref($_[0]), @_) 3069e0680481Safresh1 : objectify(2, @_); 30709f11ffb7Safresh1 3071e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 30729f11ffb7Safresh1 30739f11ffb7Safresh1 return $x if $x->modify('bnok'); 30749f11ffb7Safresh1 30759f11ffb7Safresh1 return $x->bnan() if $x->is_nan() || $y->is_nan(); 3076b46d8ef2Safresh1 return $x->bnan() if (($x->is_finite() && !$x->is_int()) || 3077b46d8ef2Safresh1 ($y->is_finite() && !$y->is_int())); 30789f11ffb7Safresh1 3079b46d8ef2Safresh1 my $xint = Math::BigInt -> new($x -> bsstr()); 3080b46d8ef2Safresh1 my $yint = Math::BigInt -> new($y -> bsstr()); 3081e0680481Safresh1 $xint = $xint -> bnok($yint); 3082e0680481Safresh1 3083e0680481Safresh1 return $xint if defined $downgrade; 3084e0680481Safresh1 3085b46d8ef2Safresh1 my $xflt = Math::BigFloat -> new($xint); 30869f11ffb7Safresh1 3087b46d8ef2Safresh1 $x->{_m} = $xflt->{_m}; 3088b46d8ef2Safresh1 $x->{_e} = $xflt->{_e}; 3089b46d8ef2Safresh1 $x->{_es} = $xflt->{_es}; 3090b46d8ef2Safresh1 $x->{sign} = $xflt->{sign}; 3091b46d8ef2Safresh1 3092b46d8ef2Safresh1 return $x; 30939f11ffb7Safresh1} 30949f11ffb7Safresh1 30959f11ffb7Safresh1sub bsin { 30969f11ffb7Safresh1 # Calculate a sinus of x. 30979f11ffb7Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 30989f11ffb7Safresh1 3099*3d61058aSafresh1 # First we apply range reduction to x. This is because if x is large, the 3100*3d61058aSafresh1 # Taylor series converges slowly and requires higher accuracy in the 3101*3d61058aSafresh1 # intermediate computation. The Taylor series is: 3102*3d61058aSafresh1 # 3103*3d61058aSafresh1 # x^3 x^5 x^7 x^9 3104*3d61058aSafresh1 # sin(x) = x - --- + --- - --- + --- ... 31059f11ffb7Safresh1 # 3! 5! 7! 9! 31069f11ffb7Safresh1 3107e0680481Safresh1 return $x if $x -> modify('bsin'); 3108e0680481Safresh1 3109e0680481Safresh1 return $x -> bzero(@r) if $x -> is_zero(); 3110e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan() || $x -> is_inf(); 3111e0680481Safresh1 3112*3d61058aSafresh1 # Get the rounding parameters, if any. 3113*3d61058aSafresh1 31149f11ffb7Safresh1 my $fallback = 0; 31159f11ffb7Safresh1 my ($scale, @params); 31169f11ffb7Safresh1 ($x, @params) = $x -> _find_round_parameters(@r); 31179f11ffb7Safresh1 3118*3d61058aSafresh1 # Error in _find_round_parameters? 3119*3d61058aSafresh1 3120e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan(); 31219f11ffb7Safresh1 3122*3d61058aSafresh1 # If no rounding parameters are given, use fallback. 3123*3d61058aSafresh1 3124*3d61058aSafresh1 if (!@params) { 3125*3d61058aSafresh1 $params[0] = $class -> div_scale(); # fallback accuracy 3126*3d61058aSafresh1 $params[1] = undef; # no precision 3127*3d61058aSafresh1 $params[2] = $r[2]; # rounding mode 3128*3d61058aSafresh1 $scale = $params[0]; 31299f11ffb7Safresh1 $fallback = 1; # to clear a/p afterwards 31309f11ffb7Safresh1 } else { 3131*3d61058aSafresh1 if (defined($params[0])) { 3132*3d61058aSafresh1 $scale = $params[0]; 3133*3d61058aSafresh1 } else { 3134*3d61058aSafresh1 # We perform the computations below using accuracy only, not 3135*3d61058aSafresh1 # precision, so when precision is given, we need to "convert" this 3136*3d61058aSafresh1 # to accuracy. 3137*3d61058aSafresh1 $scale = 1 - $params[1]; 3138*3d61058aSafresh1 } 31399f11ffb7Safresh1 } 31409f11ffb7Safresh1 3141*3d61058aSafresh1 # Add more digits to the scale if the magnitude of $x is large. 3142*3d61058aSafresh1 3143*3d61058aSafresh1 my ($m, $e) = $x -> nparts(); 3144*3d61058aSafresh1 $scale += $e if $x >= 10; 3145*3d61058aSafresh1 $scale = 4 if $scale < 4; 3146*3d61058aSafresh1 3147*3d61058aSafresh1 # When user set globals, they would interfere with our calculation, so 31489f11ffb7Safresh1 # disable them and later re-enable them 3149*3d61058aSafresh1 3150*3d61058aSafresh1 my $ab = $class -> accuracy(); 3151*3d61058aSafresh1 my $pb = $class -> precision(); 3152*3d61058aSafresh1 $class -> accuracy(undef); 3153*3d61058aSafresh1 $class -> precision(undef); 3154e0680481Safresh1 3155e0680481Safresh1 # Disabling upgrading and downgrading is no longer necessary to avoid an 3156e0680481Safresh1 # infinite recursion, but it avoids unnecessary upgrading and downgrading in 3157e0680481Safresh1 # the intermediate computations. 3158e0680481Safresh1 3159*3d61058aSafresh1 my $upg = $class -> upgrade(); 3160*3d61058aSafresh1 my $dng = $class -> downgrade(); 3161*3d61058aSafresh1 $class -> upgrade(undef); 3162*3d61058aSafresh1 $class -> downgrade(undef); 31639f11ffb7Safresh1 3164*3d61058aSafresh1 # We also need to disable any set A or P on $x (_find_round_parameters took 3165*3d61058aSafresh1 # them already into account), since these would interfere, too. 31669f11ffb7Safresh1 3167*3d61058aSafresh1 $x->{accuracy} = undef; 3168*3d61058aSafresh1 $x->{precision} = undef; 3169*3d61058aSafresh1 3170*3d61058aSafresh1 my $sin_prev; # the previous approximation of sin(x) 3171*3d61058aSafresh1 my $sin; # the current approximation of sin(x) 3172*3d61058aSafresh1 3173e0680481Safresh1 while (1) { 31749f11ffb7Safresh1 3175*3d61058aSafresh1 # Compute constants to the current scale. 3176*3d61058aSafresh1 3177*3d61058aSafresh1 my $pi = $class -> bpi($scale); # 3178*3d61058aSafresh1 my $twopi = $pi -> copy() -> bmul("2"); # 2 3179*3d61058aSafresh1 my $halfpi = $pi -> copy() -> bmul("0.5"); # /2 3180*3d61058aSafresh1 3181*3d61058aSafresh1 # Use the fact that sin(-x) = -sin(x) to reduce the range to the 3182*3d61058aSafresh1 # interval to [0,∞). 3183*3d61058aSafresh1 3184*3d61058aSafresh1 my $xsgn = $x < 0 ? -1 : 1; 3185*3d61058aSafresh1 my $x = $x -> copy() -> babs(); 3186*3d61058aSafresh1 3187*3d61058aSafresh1 # Use the fact that sin(2x) = sin(x) to reduce the range to the 3188*3d61058aSafresh1 # interval to [0, 2). 3189*3d61058aSafresh1 3190*3d61058aSafresh1 $x = $x -> bmod($twopi, $scale); 3191*3d61058aSafresh1 3192*3d61058aSafresh1 # Use the fact that sin(x+) = -sin(x) to reduce the range to the 3193*3d61058aSafresh1 # interval to [0,). 3194*3d61058aSafresh1 3195*3d61058aSafresh1 if ($x -> bcmp($pi) > 0) { 3196*3d61058aSafresh1 $xsgn = -$xsgn; 3197*3d61058aSafresh1 $x = $x -> bsub($pi); 31989f11ffb7Safresh1 } 31999f11ffb7Safresh1 3200*3d61058aSafresh1 # Use the fact that sin(-x) = sin(x) to reduce the range to the 3201*3d61058aSafresh1 # interval [0,/2). 3202*3d61058aSafresh1 3203*3d61058aSafresh1 if ($x -> bcmp($halfpi) > 0) { 3204*3d61058aSafresh1 $x = $x -> bsub($pi) -> bneg(); # - x 32059f11ffb7Safresh1 } 3206*3d61058aSafresh1 3207*3d61058aSafresh1 my $tol = $class -> new("1E-". ($scale-1)); 3208*3d61058aSafresh1 3209*3d61058aSafresh1 my $xsq = $x -> copy() -> bmul($x, $scale) -> bneg(); 3210*3d61058aSafresh1 my $term = $x -> copy(); 3211*3d61058aSafresh1 my $fac = $class -> bone(); 3212*3d61058aSafresh1 my $n = $class -> bone(); 3213*3d61058aSafresh1 3214*3d61058aSafresh1 $sin = $x -> copy(); # initialize sin(x) to the first term 3215*3d61058aSafresh1 3216*3d61058aSafresh1 while (1) { 3217*3d61058aSafresh1 $n -> binc(); 3218*3d61058aSafresh1 $fac = $n -> copy(); 3219*3d61058aSafresh1 $n -> binc(); 3220*3d61058aSafresh1 $fac -> bmul($n); 3221*3d61058aSafresh1 3222*3d61058aSafresh1 $term -> bmul($xsq, $scale) -> bdiv($fac, $scale); 3223*3d61058aSafresh1 3224*3d61058aSafresh1 $sin -> badd($term, $scale); 3225*3d61058aSafresh1 last if $term -> copy() -> babs() -> bcmp($tol) < 0; 3226*3d61058aSafresh1 } 3227*3d61058aSafresh1 3228*3d61058aSafresh1 $sin -> bneg() if $xsgn < 0; 3229*3d61058aSafresh1 3230*3d61058aSafresh1 # Rounding parameters given as arguments currently don't override 3231*3d61058aSafresh1 # instance variables, so accuracy (which is set in the computations 3232*3d61058aSafresh1 # above) must be undefined before rounding. Fixme. 3233*3d61058aSafresh1 3234*3d61058aSafresh1 $sin->{accuracy} = undef; 3235*3d61058aSafresh1 $sin -> round(@params); 3236*3d61058aSafresh1 3237*3d61058aSafresh1 # Compare the current approximation of sin(x) with the previous one, 3238*3d61058aSafresh1 # and if they are identical, we're done. 3239*3d61058aSafresh1 3240*3d61058aSafresh1 if (defined $sin_prev) { 3241*3d61058aSafresh1 last if $sin -> bcmp($sin_prev) == 0; 3242*3d61058aSafresh1 } 3243*3d61058aSafresh1 3244*3d61058aSafresh1 # If the current approximation of sin(x) is different from the previous 3245*3d61058aSafresh1 # approximation, double the scale (accuracy) and retry. 3246*3d61058aSafresh1 3247*3d61058aSafresh1 $sin_prev = $sin; 3248*3d61058aSafresh1 $scale *= 2; 3249*3d61058aSafresh1 } 3250*3d61058aSafresh1 3251*3d61058aSafresh1 # Assign the result to the invocand. 3252*3d61058aSafresh1 3253*3d61058aSafresh1 %$x = %$sin; 3254*3d61058aSafresh1 32559f11ffb7Safresh1 if ($fallback) { 32569f11ffb7Safresh1 # clear a/p after round, since user did not request it 3257*3d61058aSafresh1 $x->{accuracy} = undef; 3258*3d61058aSafresh1 $x->{precision} = undef; 32599f11ffb7Safresh1 } 3260e0680481Safresh1 3261*3d61058aSafresh1 # Restore globals. We need to do it like this, because setting one 3262*3d61058aSafresh1 # undefines the other. 3263*3d61058aSafresh1 3264*3d61058aSafresh1 if (defined $ab) { 3265*3d61058aSafresh1 $class -> accuracy($ab); 3266*3d61058aSafresh1 } else { 3267*3d61058aSafresh1 $class -> precision($pb); 3268*3d61058aSafresh1 } 3269*3d61058aSafresh1 3270*3d61058aSafresh1 $class -> upgrade($upg); 3271*3d61058aSafresh1 $class -> downgrade($dng); 3272*3d61058aSafresh1 3273*3d61058aSafresh1 # If downgrading, remember to preserve the relevant instance parameters. 3274*3d61058aSafresh1 # There should be a more elegant way to do this. Fixme. 3275*3d61058aSafresh1 3276*3d61058aSafresh1 if ($downgrade && $x -> is_int()) { 3277*3d61058aSafresh1 @r = ($x->{accuracy}, $x->{_r}); 3278*3d61058aSafresh1 my $tmp = $downgrade -> new($x, @r); 3279*3d61058aSafresh1 %$x = %$tmp; 3280*3d61058aSafresh1 return bless $x, $downgrade; 3281*3d61058aSafresh1 } 3282*3d61058aSafresh1 32839f11ffb7Safresh1 $x; 32849f11ffb7Safresh1} 32859f11ffb7Safresh1 32869f11ffb7Safresh1sub bcos { 32879f11ffb7Safresh1 # Calculate a cosinus of x. 32889f11ffb7Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 32899f11ffb7Safresh1 32909f11ffb7Safresh1 # Taylor: x^2 x^4 x^6 x^8 32919f11ffb7Safresh1 # cos = 1 - --- + --- - --- + --- ... 32929f11ffb7Safresh1 # 2! 4! 6! 8! 32939f11ffb7Safresh1 32949f11ffb7Safresh1 # we need to limit the accuracy to protect against overflow 32959f11ffb7Safresh1 my $fallback = 0; 32969f11ffb7Safresh1 my ($scale, @params); 32979f11ffb7Safresh1 ($x, @params) = $x->_find_round_parameters(@r); 32989f11ffb7Safresh1 32999f11ffb7Safresh1 # constant object or error in _find_round_parameters? 33009f11ffb7Safresh1 return $x if $x->modify('bcos') || $x->is_nan(); 3301eac174f2Safresh1 return $x->bnan() if $x->is_inf(); 33029f11ffb7Safresh1 return $x->bone(@r) if $x->is_zero(); 33039f11ffb7Safresh1 33049f11ffb7Safresh1 # no rounding at all, so must use fallback 33059f11ffb7Safresh1 if (scalar @params == 0) { 33069f11ffb7Safresh1 # simulate old behaviour 33079f11ffb7Safresh1 $params[0] = $class->div_scale(); # and round to it as accuracy 33089f11ffb7Safresh1 $params[1] = undef; # disable P 33099f11ffb7Safresh1 $scale = $params[0]+4; # at least four more for proper round 33109f11ffb7Safresh1 $params[2] = $r[2]; # round mode by caller or undef 33119f11ffb7Safresh1 $fallback = 1; # to clear a/p afterwards 33129f11ffb7Safresh1 } else { 33139f11ffb7Safresh1 # the 4 below is empirical, and there might be cases where it is not 33149f11ffb7Safresh1 # enough... 33159f11ffb7Safresh1 $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined 33169f11ffb7Safresh1 } 33179f11ffb7Safresh1 3318*3d61058aSafresh1 # When user set globals, they would interfere with our calculation, so 3319*3d61058aSafresh1 # disable them and later re-enable them. 3320*3d61058aSafresh1 3321*3d61058aSafresh1 my $ab = $class -> accuracy(); 3322*3d61058aSafresh1 my $pb = $class -> precision(); 3323*3d61058aSafresh1 $class -> accuracy(undef); 3324*3d61058aSafresh1 $class -> precision(undef); 3325*3d61058aSafresh1 3326*3d61058aSafresh1 # Disabling upgrading and downgrading is no longer necessary to avoid an 3327*3d61058aSafresh1 # infinite recursion, but it avoids unnecessary upgrading and downgrading in 3328*3d61058aSafresh1 # the intermediate computations. 3329*3d61058aSafresh1 3330*3d61058aSafresh1 my $upg = $class -> upgrade(); 3331*3d61058aSafresh1 my $dng = $class -> downgrade(); 3332*3d61058aSafresh1 $class -> upgrade(undef); 3333*3d61058aSafresh1 $class -> downgrade(undef); 3334*3d61058aSafresh1 3335*3d61058aSafresh1 # We also need to disable any set A or P on $x (_find_round_parameters took 3336*3d61058aSafresh1 # them already into account), since these would interfere, too. 3337*3d61058aSafresh1 3338*3d61058aSafresh1 $x->{accuracy} = undef; 3339*3d61058aSafresh1 $x->{precision} = undef; 33409f11ffb7Safresh1 33419f11ffb7Safresh1 my $over = $x * $x; # X ^ 2 33429f11ffb7Safresh1 my $x2 = $over->copy(); # X ^ 2; difference between terms 33439f11ffb7Safresh1 my $sign = 1; # start with -= 33449f11ffb7Safresh1 my $below = $class->new(2); 33459f11ffb7Safresh1 my $factorial = $class->new(3); 3346e0680481Safresh1 $x = $x->bone(); 3347*3d61058aSafresh1 $x->{accuracy} = undef; 3348*3d61058aSafresh1 $x->{precision} = undef; 33499f11ffb7Safresh1 33509f11ffb7Safresh1 my $limit = $class->new("1E-". ($scale-1)); 33519f11ffb7Safresh1 #my $steps = 0; 33529f11ffb7Safresh1 while (3 < 5) { 33539f11ffb7Safresh1 # we calculate the next term, and add it to the last 33549f11ffb7Safresh1 # when the next term is below our limit, it won't affect the outcome 33559f11ffb7Safresh1 # anymore, so we stop: 33569f11ffb7Safresh1 my $next = $over->copy()->bdiv($below, $scale); 33579f11ffb7Safresh1 last if $next->bacmp($limit) <= 0; 33589f11ffb7Safresh1 33599f11ffb7Safresh1 if ($sign == 0) { 3360e0680481Safresh1 $x = $x->badd($next); 33619f11ffb7Safresh1 } else { 3362e0680481Safresh1 $x = $x->bsub($next); 33639f11ffb7Safresh1 } 33649f11ffb7Safresh1 $sign = 1-$sign; # alternate 33659f11ffb7Safresh1 # calculate things for the next term 3366e0680481Safresh1 $over = $over->bmul($x2); # $x*$x 3367e0680481Safresh1 $below = $below->bmul($factorial); # n*(n+1) 3368e0680481Safresh1 $factorial = $factorial -> binc(); 3369e0680481Safresh1 $below = $below->bmul($factorial); # n*(n+1) 3370e0680481Safresh1 $factorial = $factorial -> binc(); 33719f11ffb7Safresh1 } 33729f11ffb7Safresh1 33739f11ffb7Safresh1 # shortcut to not run through _find_round_parameters again 33749f11ffb7Safresh1 if (defined $params[0]) { 3375e0680481Safresh1 $x = $x->bround($params[0], $params[2]); # then round accordingly 33769f11ffb7Safresh1 } else { 3377e0680481Safresh1 $x = $x->bfround($params[1], $params[2]); # then round accordingly 33789f11ffb7Safresh1 } 33799f11ffb7Safresh1 if ($fallback) { 33809f11ffb7Safresh1 # clear a/p after round, since user did not request it 3381*3d61058aSafresh1 $x->{accuracy} = undef; 3382*3d61058aSafresh1 $x->{precision} = undef; 33839f11ffb7Safresh1 } 3384*3d61058aSafresh1 3385*3d61058aSafresh1 # Restore globals. We need to do it like this, because setting one 3386*3d61058aSafresh1 # undefines the other. 3387*3d61058aSafresh1 3388*3d61058aSafresh1 if (defined $ab) { 3389*3d61058aSafresh1 $class -> accuracy($ab); 3390*3d61058aSafresh1 } else { 3391*3d61058aSafresh1 $class -> precision($pb); 3392*3d61058aSafresh1 } 3393*3d61058aSafresh1 3394*3d61058aSafresh1 $class -> upgrade($upg); 3395*3d61058aSafresh1 $class -> downgrade($dng); 3396e0680481Safresh1 3397e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 3398e0680481Safresh1 if defined($downgrade) && $x -> is_int(); 33999f11ffb7Safresh1 $x; 34009f11ffb7Safresh1} 34019f11ffb7Safresh1 34029f11ffb7Safresh1sub batan { 34039f11ffb7Safresh1 # Calculate a arcus tangens of x. 3404e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 34059f11ffb7Safresh1 34069f11ffb7Safresh1 # taylor: x^3 x^5 x^7 x^9 34079f11ffb7Safresh1 # atan = x - --- + --- - --- + --- ... 34089f11ffb7Safresh1 # 3 5 7 9 34099f11ffb7Safresh1 3410e0680481Safresh1 return $x if $x->modify('batan'); 3411e0680481Safresh1 3412e0680481Safresh1 return $x -> bnan(@r) if $x->is_nan(); 3413e0680481Safresh1 34149f11ffb7Safresh1 # We need to limit the accuracy to protect against overflow. 34159f11ffb7Safresh1 34169f11ffb7Safresh1 my $fallback = 0; 34179f11ffb7Safresh1 my ($scale, @params); 3418e0680481Safresh1 ($x, @params) = $x->_find_round_parameters(@r); 34199f11ffb7Safresh1 3420e0680481Safresh1 # Error in _find_round_parameters? 34219f11ffb7Safresh1 3422e0680481Safresh1 return $x -> bnan(@r) if $x->is_nan(); 34239f11ffb7Safresh1 3424e0680481Safresh1 if ($x->{sign} =~ /^[+-]inf\z/) { 34259f11ffb7Safresh1 # +inf result is PI/2 34269f11ffb7Safresh1 # -inf result is -PI/2 34279f11ffb7Safresh1 # calculate PI/2 34289f11ffb7Safresh1 my $pi = $class->bpi(@r); 3429e0680481Safresh1 # modify $x in place 3430e0680481Safresh1 $x->{_m} = $pi->{_m}; 3431e0680481Safresh1 $x->{_e} = $pi->{_e}; 3432e0680481Safresh1 $x->{_es} = $pi->{_es}; 34339f11ffb7Safresh1 # -y => -PI/2, +y => PI/2 3434e0680481Safresh1 $x->{sign} = substr($x->{sign}, 0, 1); # "+inf" => "+" 3435e0680481Safresh1 $x -> {_m} = $LIB->_div($x->{_m}, $LIB->_new(2)); 3436e0680481Safresh1 return $x; 34379f11ffb7Safresh1 } 34389f11ffb7Safresh1 3439e0680481Safresh1 return $x->bzero(@r) if $x->is_zero(); 34409f11ffb7Safresh1 34419f11ffb7Safresh1 # no rounding at all, so must use fallback 34429f11ffb7Safresh1 if (scalar @params == 0) { 34439f11ffb7Safresh1 # simulate old behaviour 34449f11ffb7Safresh1 $params[0] = $class->div_scale(); # and round to it as accuracy 34459f11ffb7Safresh1 $params[1] = undef; # disable P 34469f11ffb7Safresh1 $scale = $params[0]+4; # at least four more for proper round 34479f11ffb7Safresh1 $params[2] = $r[2]; # round mode by caller or undef 34489f11ffb7Safresh1 $fallback = 1; # to clear a/p afterwards 34499f11ffb7Safresh1 } else { 34509f11ffb7Safresh1 # the 4 below is empirical, and there might be cases where it is not 34519f11ffb7Safresh1 # enough... 34529f11ffb7Safresh1 $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined 34539f11ffb7Safresh1 } 34549f11ffb7Safresh1 34559f11ffb7Safresh1 # 1 or -1 => PI/4 34569f11ffb7Safresh1 # inlined is_one() && is_one('-') 3457e0680481Safresh1 if ($LIB->_is_one($x->{_m}) && $LIB->_is_zero($x->{_e})) { 34589f11ffb7Safresh1 my $pi = $class->bpi($scale - 3); 3459e0680481Safresh1 # modify $x in place 3460e0680481Safresh1 $x->{_m} = $pi->{_m}; 3461e0680481Safresh1 $x->{_e} = $pi->{_e}; 3462e0680481Safresh1 $x->{_es} = $pi->{_es}; 3463e0680481Safresh1 # leave the sign of $x alone (+1 => +PI/4, -1 => -PI/4) 3464e0680481Safresh1 $x->{_m} = $LIB->_div($x->{_m}, $LIB->_new(4)); 3465e0680481Safresh1 return $x; 34669f11ffb7Safresh1 } 34679f11ffb7Safresh1 34689f11ffb7Safresh1 # This series is only valid if -1 < x < 1, so for other x we need to 34699f11ffb7Safresh1 # calculate PI/2 - atan(1/x): 34709f11ffb7Safresh1 my $pi = undef; 3471e0680481Safresh1 if ($x->bacmp($x->copy()->bone) >= 0) { 34729f11ffb7Safresh1 # calculate PI/2 34739f11ffb7Safresh1 $pi = $class->bpi($scale - 3); 3474b46d8ef2Safresh1 $pi->{_m} = $LIB->_div($pi->{_m}, $LIB->_new(2)); 3475e0680481Safresh1 # calculate 1/$x: 3476e0680481Safresh1 my $x_copy = $x->copy(); 3477e0680481Safresh1 # modify $x in place 3478e0680481Safresh1 $x = $x->bone(); 3479e0680481Safresh1 $x = $x->bdiv($x_copy, $scale); 34809f11ffb7Safresh1 } 34819f11ffb7Safresh1 34829f11ffb7Safresh1 my $fmul = 1; 3483b46d8ef2Safresh1 foreach (0 .. int($scale / 20)) { 34849f11ffb7Safresh1 $fmul *= 2; 3485e0680481Safresh1 $x = $x->bdiv($x->copy()->bmul($x)->binc()->bsqrt($scale + 4)->binc(), 3486e0680481Safresh1 $scale + 4); 34879f11ffb7Safresh1 } 34889f11ffb7Safresh1 34899f11ffb7Safresh1 # When user set globals, they would interfere with our calculation, so 34909f11ffb7Safresh1 # disable them and later re-enable them. 3491*3d61058aSafresh1 3492*3d61058aSafresh1 my $ab = $class -> accuracy(); 3493*3d61058aSafresh1 my $pb = $class -> precision(); 3494*3d61058aSafresh1 $class -> accuracy(undef); 3495*3d61058aSafresh1 $class -> precision(undef); 34969f11ffb7Safresh1 3497e0680481Safresh1 # Disabling upgrading and downgrading is no longer necessary to avoid an 3498e0680481Safresh1 # infinite recursion, but it avoids unnecessary upgrading and downgrading in 3499e0680481Safresh1 # the intermediate computations. 3500e0680481Safresh1 3501*3d61058aSafresh1 my $upg = $class -> upgrade(); 3502*3d61058aSafresh1 my $dng = $class -> downgrade(); 3503*3d61058aSafresh1 $class -> upgrade(undef); 3504*3d61058aSafresh1 $class -> downgrade(undef); 3505*3d61058aSafresh1 3506*3d61058aSafresh1 # We also need to disable any set A or P on $x (_find_round_parameters took 3507*3d61058aSafresh1 # them already into account), since these would interfere, too. 3508*3d61058aSafresh1 3509*3d61058aSafresh1 $x->{accuracy} = undef; 3510*3d61058aSafresh1 $x->{precision} = undef; 3511e0680481Safresh1 3512e0680481Safresh1 my $over = $x * $x; # X ^ 2 3513e0680481Safresh1 my $x2 = $over->copy(); # X ^ 2; difference between terms 3514e0680481Safresh1 $over = $over->bmul($x); # X ^ 3 as starting value 35159f11ffb7Safresh1 my $sign = 1; # start with -= 35169f11ffb7Safresh1 my $below = $class->new(3); 35179f11ffb7Safresh1 my $two = $class->new(2); 3518*3d61058aSafresh1 $x->{accuracy} = undef; 3519*3d61058aSafresh1 $x->{precision} = undef; 35209f11ffb7Safresh1 35219f11ffb7Safresh1 my $limit = $class->new("1E-". ($scale-1)); 35229f11ffb7Safresh1 #my $steps = 0; 35239f11ffb7Safresh1 while (1) { 35249f11ffb7Safresh1 # We calculate the next term, and add it to the last. When the next 35259f11ffb7Safresh1 # term is below our limit, it won't affect the outcome anymore, so we 35269f11ffb7Safresh1 # stop: 35279f11ffb7Safresh1 my $next = $over->copy()->bdiv($below, $scale); 35289f11ffb7Safresh1 last if $next->bacmp($limit) <= 0; 35299f11ffb7Safresh1 35309f11ffb7Safresh1 if ($sign == 0) { 3531e0680481Safresh1 $x = $x->badd($next); 35329f11ffb7Safresh1 } else { 3533e0680481Safresh1 $x = $x->bsub($next); 35349f11ffb7Safresh1 } 35359f11ffb7Safresh1 $sign = 1-$sign; # alternatex 35369f11ffb7Safresh1 # calculate things for the next term 3537e0680481Safresh1 $over = $over->bmul($x2); # $x*$x 3538e0680481Safresh1 $below = $below->badd($two); # n += 2 35399f11ffb7Safresh1 } 3540e0680481Safresh1 $x = $x->bmul($fmul); 35419f11ffb7Safresh1 35429f11ffb7Safresh1 if (defined $pi) { 3543e0680481Safresh1 my $x_copy = $x->copy(); 3544e0680481Safresh1 # modify $x in place 3545e0680481Safresh1 $x->{_m} = $pi->{_m}; 3546e0680481Safresh1 $x->{_e} = $pi->{_e}; 3547e0680481Safresh1 $x->{_es} = $pi->{_es}; 3548e0680481Safresh1 # PI/2 - $x 3549e0680481Safresh1 $x = $x->bsub($x_copy); 35509f11ffb7Safresh1 } 35519f11ffb7Safresh1 35529f11ffb7Safresh1 # Shortcut to not run through _find_round_parameters again. 35539f11ffb7Safresh1 if (defined $params[0]) { 3554e0680481Safresh1 $x = $x->bround($params[0], $params[2]); # then round accordingly 35559f11ffb7Safresh1 } else { 3556e0680481Safresh1 $x = $x->bfround($params[1], $params[2]); # then round accordingly 35579f11ffb7Safresh1 } 35589f11ffb7Safresh1 if ($fallback) { 35599f11ffb7Safresh1 # Clear a/p after round, since user did not request it. 3560*3d61058aSafresh1 $x->{accuracy} = undef; 3561*3d61058aSafresh1 $x->{precision} = undef; 35629f11ffb7Safresh1 } 35639f11ffb7Safresh1 3564*3d61058aSafresh1 # Restore globals. We need to do it like this, because setting one 3565*3d61058aSafresh1 # undefines the other. 3566*3d61058aSafresh1 3567*3d61058aSafresh1 if (defined $ab) { 3568*3d61058aSafresh1 $class -> accuracy($ab); 3569*3d61058aSafresh1 } else { 3570*3d61058aSafresh1 $class -> precision($pb); 3571*3d61058aSafresh1 } 3572*3d61058aSafresh1 3573*3d61058aSafresh1 $class -> upgrade($upg); 3574*3d61058aSafresh1 $class -> downgrade($dng); 3575e0680481Safresh1 3576e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 3577e0680481Safresh1 if defined($downgrade) && ($x -> is_int() || $x -> is_inf()); 3578e0680481Safresh1 $x; 35799f11ffb7Safresh1} 35809f11ffb7Safresh1 35819f11ffb7Safresh1sub batan2 { 35829f11ffb7Safresh1 # $y -> batan2($x) returns the arcus tangens of $y / $x. 35839f11ffb7Safresh1 35849f11ffb7Safresh1 # Set up parameters. 3585e0680481Safresh1 my ($class, $y, $x, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 3586e0680481Safresh1 ? (ref($_[0]), @_) 3587e0680481Safresh1 : objectify(2, @_); 35889f11ffb7Safresh1 35899f11ffb7Safresh1 # Quick exit if $y is read-only. 35909f11ffb7Safresh1 return $y if $y -> modify('batan2'); 35919f11ffb7Safresh1 35929f11ffb7Safresh1 # Handle all NaN cases. 35939f11ffb7Safresh1 return $y -> bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan; 35949f11ffb7Safresh1 35959f11ffb7Safresh1 # We need to limit the accuracy to protect against overflow. 35969f11ffb7Safresh1 my $fallback = 0; 35979f11ffb7Safresh1 my ($scale, @params); 35989f11ffb7Safresh1 ($y, @params) = $y -> _find_round_parameters(@r); 35999f11ffb7Safresh1 36009f11ffb7Safresh1 # Error in _find_round_parameters? 36019f11ffb7Safresh1 return $y if $y->is_nan(); 36029f11ffb7Safresh1 36039f11ffb7Safresh1 # No rounding at all, so must use fallback. 36049f11ffb7Safresh1 if (scalar @params == 0) { 36059f11ffb7Safresh1 # Simulate old behaviour 36069f11ffb7Safresh1 $params[0] = $class -> div_scale(); # and round to it as accuracy 36079f11ffb7Safresh1 $params[1] = undef; # disable P 36089f11ffb7Safresh1 $scale = $params[0] + 4; # at least four more for proper round 36099f11ffb7Safresh1 $params[2] = $r[2]; # round mode by caller or undef 36109f11ffb7Safresh1 $fallback = 1; # to clear a/p afterwards 36119f11ffb7Safresh1 } else { 36129f11ffb7Safresh1 # The 4 below is empirical, and there might be cases where it is not 36139f11ffb7Safresh1 # enough ... 36149f11ffb7Safresh1 $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined 36159f11ffb7Safresh1 } 36169f11ffb7Safresh1 36179f11ffb7Safresh1 if ($x -> is_inf("+")) { # x = inf 36189f11ffb7Safresh1 if ($y -> is_inf("+")) { # y = inf 3619e0680481Safresh1 $y = $y -> bpi($scale) -> bmul("0.25"); # pi/4 36209f11ffb7Safresh1 } elsif ($y -> is_inf("-")) { # y = -inf 3621e0680481Safresh1 $y = $y -> bpi($scale) -> bmul("-0.25"); # -pi/4 36229f11ffb7Safresh1 } else { # -inf < y < inf 36239f11ffb7Safresh1 return $y -> bzero(@r); # 0 36249f11ffb7Safresh1 } 36259f11ffb7Safresh1 } elsif ($x -> is_inf("-")) { # x = -inf 36269f11ffb7Safresh1 if ($y -> is_inf("+")) { # y = inf 3627e0680481Safresh1 $y = $y -> bpi($scale) -> bmul("0.75"); # 3/4 pi 36289f11ffb7Safresh1 } elsif ($y -> is_inf("-")) { # y = -inf 3629e0680481Safresh1 $y = $y -> bpi($scale) -> bmul("-0.75"); # -3/4 pi 36309f11ffb7Safresh1 } elsif ($y >= 0) { # y >= 0 3631e0680481Safresh1 $y = $y -> bpi($scale); # pi 36329f11ffb7Safresh1 } else { # y < 0 3633e0680481Safresh1 $y = $y -> bpi($scale) -> bneg(); # -pi 36349f11ffb7Safresh1 } 36359f11ffb7Safresh1 } elsif ($x > 0) { # 0 < x < inf 36369f11ffb7Safresh1 if ($y -> is_inf("+")) { # y = inf 3637e0680481Safresh1 $y = $y -> bpi($scale) -> bmul("0.5"); # pi/2 36389f11ffb7Safresh1 } elsif ($y -> is_inf("-")) { # y = -inf 3639e0680481Safresh1 $y = $y -> bpi($scale) -> bmul("-0.5"); # -pi/2 36409f11ffb7Safresh1 } else { # -inf < y < inf 3641e0680481Safresh1 $y = $y -> bdiv($x, $scale) -> batan($scale); # atan(y/x) 36429f11ffb7Safresh1 } 36439f11ffb7Safresh1 } elsif ($x < 0) { # -inf < x < 0 36449f11ffb7Safresh1 my $pi = $class -> bpi($scale); 36459f11ffb7Safresh1 if ($y >= 0) { # y >= 0 3646e0680481Safresh1 $y = $y -> bdiv($x, $scale) -> batan() # atan(y/x) + pi 36479f11ffb7Safresh1 -> badd($pi); 36489f11ffb7Safresh1 } else { # y < 0 3649e0680481Safresh1 $y = $y -> bdiv($x, $scale) -> batan() # atan(y/x) - pi 36509f11ffb7Safresh1 -> bsub($pi); 36519f11ffb7Safresh1 } 36529f11ffb7Safresh1 } else { # x = 0 36539f11ffb7Safresh1 if ($y > 0) { # y > 0 3654e0680481Safresh1 $y = $y -> bpi($scale) -> bmul("0.5"); # pi/2 36559f11ffb7Safresh1 } elsif ($y < 0) { # y < 0 3656e0680481Safresh1 $y = $y -> bpi($scale) -> bmul("-0.5"); # -pi/2 36579f11ffb7Safresh1 } else { # y = 0 36589f11ffb7Safresh1 return $y -> bzero(@r); # 0 36599f11ffb7Safresh1 } 36609f11ffb7Safresh1 } 36619f11ffb7Safresh1 3662e0680481Safresh1 $y = $y -> round(@r); 36639f11ffb7Safresh1 36649f11ffb7Safresh1 if ($fallback) { 3665*3d61058aSafresh1 $y->{accuracy} = undef; 3666*3d61058aSafresh1 $y->{precision} = undef; 36679f11ffb7Safresh1 } 36689f11ffb7Safresh1 36699f11ffb7Safresh1 return $y; 36709f11ffb7Safresh1} 36719f11ffb7Safresh1 36729f11ffb7Safresh1sub bsqrt { 36739f11ffb7Safresh1 # calculate square root 3674e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 36759f11ffb7Safresh1 36769f11ffb7Safresh1 return $x if $x->modify('bsqrt'); 36779f11ffb7Safresh1 3678e0680481Safresh1 # Handle trivial cases. 3679e0680481Safresh1 3680e0680481Safresh1 return $x -> bnan(@r) if $x->is_nan(); 3681e0680481Safresh1 return $x -> binf("+", @r) if $x->{sign} eq '+inf'; 3682e0680481Safresh1 return $x -> round(@r) if $x->is_zero() || $x->is_one(); 3683e0680481Safresh1 3684e0680481Safresh1 # We don't support complex numbers. 3685e0680481Safresh1 3686e0680481Safresh1 if ($x -> is_neg()) { 3687e0680481Safresh1 return $upgrade -> bsqrt($x, @r) if defined($upgrade); 3688e0680481Safresh1 return $x -> bnan(@r); 3689e0680481Safresh1 } 36909f11ffb7Safresh1 36919f11ffb7Safresh1 # we need to limit the accuracy to protect against overflow 36929f11ffb7Safresh1 my $fallback = 0; 36939f11ffb7Safresh1 my (@params, $scale); 3694e0680481Safresh1 ($x, @params) = $x->_find_round_parameters(@r); 36959f11ffb7Safresh1 3696e0680481Safresh1 # error in _find_round_parameters? 3697e0680481Safresh1 return $x -> bnan(@r) if $x->is_nan(); 36989f11ffb7Safresh1 36999f11ffb7Safresh1 # no rounding at all, so must use fallback 37009f11ffb7Safresh1 if (scalar @params == 0) { 37019f11ffb7Safresh1 # simulate old behaviour 37029f11ffb7Safresh1 $params[0] = $class->div_scale(); # and round to it as accuracy 37039f11ffb7Safresh1 $scale = $params[0]+4; # at least four more for proper round 3704e0680481Safresh1 $params[2] = $r[2]; # round mode by caller or undef 37059f11ffb7Safresh1 $fallback = 1; # to clear a/p afterwards 37069f11ffb7Safresh1 } else { 37079f11ffb7Safresh1 # the 4 below is empirical, and there might be cases where it is not 37089f11ffb7Safresh1 # enough... 37099f11ffb7Safresh1 $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined 37109f11ffb7Safresh1 } 37119f11ffb7Safresh1 3712*3d61058aSafresh1 # Shift the significand left or right to get the desired number of digits, 3713*3d61058aSafresh1 # which is 2*$scale with possibly one extra digit to ensure that the 3714*3d61058aSafresh1 # exponent is an even number. 3715e0680481Safresh1 3716*3d61058aSafresh1 my $l = $LIB -> _len($x->{_m}); 3717*3d61058aSafresh1 my $n = 2 * $scale - $l; # how much should we shift? 3718*3d61058aSafresh1 $n++ if ($l % 2 xor $LIB -> _is_odd($x->{_e})); 3719*3d61058aSafresh1 my ($na, $ns) = $n < 0 ? (abs($n), "-") : ($n, "+"); 3720*3d61058aSafresh1 $na = $LIB -> _new($na); 3721e0680481Safresh1 3722*3d61058aSafresh1 $x->{_m} = $ns eq "+" ? $LIB -> _lsft($x->{_m}, $na, 10) 3723*3d61058aSafresh1 : $LIB -> _rsft($x->{_m}, $na, 10); 37249f11ffb7Safresh1 3725*3d61058aSafresh1 $x->{_m} = $LIB -> _sqrt($x->{_m}); 37269f11ffb7Safresh1 3727*3d61058aSafresh1 # Adjust the exponent by the amount that we shifted the significand. The 3728*3d61058aSafresh1 # square root of the exponent is simply half of it: sqrt(10^(2*a)) = 10^a. 37299f11ffb7Safresh1 3730*3d61058aSafresh1 ($x->{_e}, $x->{_es}) = $LIB -> _ssub($x->{_e}, $x->{_es}, $na, $ns); 3731*3d61058aSafresh1 $x->{_e} = $LIB -> _div($x->{_e}, $LIB -> _new("2")); 37329f11ffb7Safresh1 3733*3d61058aSafresh1 # Normalize to get rid of any trailing zeros in the significand. 37349f11ffb7Safresh1 3735*3d61058aSafresh1 $x -> bnorm(); 37369f11ffb7Safresh1 37379f11ffb7Safresh1 # shortcut to not run through _find_round_parameters again 37389f11ffb7Safresh1 if (defined $params[0]) { 3739e0680481Safresh1 $x = $x->bround($params[0], $params[2]); # then round accordingly 37409f11ffb7Safresh1 } else { 3741e0680481Safresh1 $x = $x->bfround($params[1], $params[2]); # then round accordingly 37429f11ffb7Safresh1 } 3743*3d61058aSafresh1 37449f11ffb7Safresh1 if ($fallback) { 37459f11ffb7Safresh1 # clear a/p after round, since user did not request it 3746*3d61058aSafresh1 $x->{accuracy} = undef; 3747*3d61058aSafresh1 $x->{precision} = undef; 37489f11ffb7Safresh1 } 3749e0680481Safresh1 3750*3d61058aSafresh1 return $downgrade -> new($x, @r) 3751*3d61058aSafresh1 if defined($downgrade) && $x -> is_int(); 37529f11ffb7Safresh1 $x; 37539f11ffb7Safresh1} 37549f11ffb7Safresh1 37559f11ffb7Safresh1sub broot { 37569f11ffb7Safresh1 # calculate $y'th root of $x 37579f11ffb7Safresh1 37589f11ffb7Safresh1 # set up parameters 3759e0680481Safresh1 my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 3760e0680481Safresh1 ? (ref($_[0]), @_) 3761e0680481Safresh1 : objectify(2, @_); 37629f11ffb7Safresh1 37639f11ffb7Safresh1 return $x if $x->modify('broot'); 37649f11ffb7Safresh1 3765e0680481Safresh1 # Handle trivial cases. 3766e0680481Safresh1 3767e0680481Safresh1 return $x -> bnan(@r) if $x->is_nan() || $y->is_nan(); 3768e0680481Safresh1 3769e0680481Safresh1 if ($x -> is_neg()) { 3770e0680481Safresh1 # -27 ** (1/3) = -3 3771e0680481Safresh1 return $x -> broot($y -> copy() -> bneg(), @r) -> bneg() 3772e0680481Safresh1 if $x -> is_int() && $y -> is_int() && $y -> is_neg(); 3773e0680481Safresh1 return $upgrade -> broot($x, $y, @r) if defined $upgrade; 3774e0680481Safresh1 return $x -> bnan(@r); 3775e0680481Safresh1 } 3776e0680481Safresh1 37779f11ffb7Safresh1 # NaN handling: $x ** 1/0, x or y NaN, or y inf/-inf or y == 0 37789f11ffb7Safresh1 return $x->bnan() if $x->{sign} !~ /^\+/ || $y->is_zero() || 37799f11ffb7Safresh1 $y->{sign} !~ /^\+$/; 37809f11ffb7Safresh1 37819f11ffb7Safresh1 return $x if $x->is_zero() || $x->is_one() || $x->is_inf() || $y->is_one(); 37829f11ffb7Safresh1 37839f11ffb7Safresh1 # we need to limit the accuracy to protect against overflow 37849f11ffb7Safresh1 my $fallback = 0; 37859f11ffb7Safresh1 my (@params, $scale); 3786e0680481Safresh1 ($x, @params) = $x->_find_round_parameters(@r); 37879f11ffb7Safresh1 37889f11ffb7Safresh1 return $x if $x->is_nan(); # error in _find_round_parameters? 37899f11ffb7Safresh1 37909f11ffb7Safresh1 # no rounding at all, so must use fallback 37919f11ffb7Safresh1 if (scalar @params == 0) { 37929f11ffb7Safresh1 # simulate old behaviour 37939f11ffb7Safresh1 $params[0] = $class->div_scale(); # and round to it as accuracy 37949f11ffb7Safresh1 $scale = $params[0]+4; # at least four more for proper round 3795e0680481Safresh1 $params[2] = $r[2]; # round mode by caller or undef 37969f11ffb7Safresh1 $fallback = 1; # to clear a/p afterwards 37979f11ffb7Safresh1 } else { 37989f11ffb7Safresh1 # the 4 below is empirical, and there might be cases where it is not 37999f11ffb7Safresh1 # enough... 38009f11ffb7Safresh1 $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined 38019f11ffb7Safresh1 } 38029f11ffb7Safresh1 3803*3d61058aSafresh1 # When user set globals, they would interfere with our calculation, so 3804*3d61058aSafresh1 # disable them and later re-enable them. 3805*3d61058aSafresh1 3806*3d61058aSafresh1 my $ab = $class -> accuracy(); 3807*3d61058aSafresh1 my $pb = $class -> precision(); 3808*3d61058aSafresh1 $class -> accuracy(undef); 3809*3d61058aSafresh1 $class -> precision(undef); 3810e0680481Safresh1 3811e0680481Safresh1 # Disabling upgrading and downgrading is no longer necessary to avoid an 3812e0680481Safresh1 # infinite recursion, but it avoids unnecessary upgrading and downgrading in 3813e0680481Safresh1 # the intermediate computations. 3814e0680481Safresh1 3815*3d61058aSafresh1 my $upg = $class -> upgrade(); 3816*3d61058aSafresh1 my $dng = $class -> downgrade(); 3817*3d61058aSafresh1 $class -> upgrade(undef); 3818*3d61058aSafresh1 $class -> downgrade(undef); 3819*3d61058aSafresh1 3820*3d61058aSafresh1 # We also need to disable any set A or P on $x (_find_round_parameters took 3821*3d61058aSafresh1 # them already into account), since these would interfere, too. 3822*3d61058aSafresh1 3823*3d61058aSafresh1 $x->{accuracy} = undef; 3824*3d61058aSafresh1 $x->{precision} = undef; 38259f11ffb7Safresh1 38269f11ffb7Safresh1 # remember sign and make $x positive, since -4 ** (1/2) => -2 38279f11ffb7Safresh1 my $sign = 0; 38289f11ffb7Safresh1 $sign = 1 if $x->{sign} eq '-'; 38299f11ffb7Safresh1 $x->{sign} = '+'; 38309f11ffb7Safresh1 38319f11ffb7Safresh1 my $is_two = 0; 38329f11ffb7Safresh1 if ($y->isa('Math::BigFloat')) { 3833e0680481Safresh1 $is_two = $y->{sign} eq '+' && $LIB->_is_two($y->{_m}) 3834e0680481Safresh1 && $LIB->_is_zero($y->{_e}); 38359f11ffb7Safresh1 } else { 3836e0680481Safresh1 $is_two = $y == 2; 38379f11ffb7Safresh1 } 38389f11ffb7Safresh1 38399f11ffb7Safresh1 # normal square root if $y == 2: 38409f11ffb7Safresh1 if ($is_two) { 3841e0680481Safresh1 $x = $x->bsqrt($scale+4); 38429f11ffb7Safresh1 } elsif ($y->is_one('-')) { 38439f11ffb7Safresh1 # $x ** -1 => 1/$x 38449f11ffb7Safresh1 my $u = $class->bone()->bdiv($x, $scale); 38459f11ffb7Safresh1 # copy private parts over 38469f11ffb7Safresh1 $x->{_m} = $u->{_m}; 38479f11ffb7Safresh1 $x->{_e} = $u->{_e}; 38489f11ffb7Safresh1 $x->{_es} = $u->{_es}; 38499f11ffb7Safresh1 } else { 38509f11ffb7Safresh1 # calculate the broot() as integer result first, and if it fits, return 38519f11ffb7Safresh1 # it rightaway (but only if $x and $y are integer): 38529f11ffb7Safresh1 38539f11ffb7Safresh1 my $done = 0; # not yet 38549f11ffb7Safresh1 if ($y->is_int() && $x->is_int()) { 3855b46d8ef2Safresh1 my $i = $LIB->_copy($x->{_m}); 3856b46d8ef2Safresh1 $i = $LIB->_lsft($i, $x->{_e}, 10) unless $LIB->_is_zero($x->{_e}); 38579f11ffb7Safresh1 my $int = Math::BigInt->bzero(); 38589f11ffb7Safresh1 $int->{value} = $i; 3859e0680481Safresh1 $int = $int->broot($y->as_number()); 38609f11ffb7Safresh1 # if ($exact) 38619f11ffb7Safresh1 if ($int->copy()->bpow($y) == $x) { 38629f11ffb7Safresh1 # found result, return it 38639f11ffb7Safresh1 $x->{_m} = $int->{value}; 3864b46d8ef2Safresh1 $x->{_e} = $LIB->_zero(); 38659f11ffb7Safresh1 $x->{_es} = '+'; 3866e0680481Safresh1 $x = $x->bnorm(); 38679f11ffb7Safresh1 $done = 1; 38689f11ffb7Safresh1 } 38699f11ffb7Safresh1 } 38709f11ffb7Safresh1 if ($done == 0) { 38719f11ffb7Safresh1 my $u = $class->bone()->bdiv($y, $scale+4); 3872*3d61058aSafresh1 $u->{accuracy} = undef; 3873*3d61058aSafresh1 $u->{precision} = undef; 3874e0680481Safresh1 $x = $x->bpow($u, $scale+4); # el cheapo 38759f11ffb7Safresh1 } 38769f11ffb7Safresh1 } 3877e0680481Safresh1 $x = $x->bneg() if $sign == 1; 38789f11ffb7Safresh1 38799f11ffb7Safresh1 # shortcut to not run through _find_round_parameters again 38809f11ffb7Safresh1 if (defined $params[0]) { 3881e0680481Safresh1 $x = $x->bround($params[0], $params[2]); # then round accordingly 38829f11ffb7Safresh1 } else { 3883e0680481Safresh1 $x = $x->bfround($params[1], $params[2]); # then round accordingly 38849f11ffb7Safresh1 } 38859f11ffb7Safresh1 if ($fallback) { 38869f11ffb7Safresh1 # clear a/p after round, since user did not request it 3887*3d61058aSafresh1 $x->{accuracy} = undef; 3888*3d61058aSafresh1 $x->{precision} = undef; 38899f11ffb7Safresh1 } 3890*3d61058aSafresh1 3891*3d61058aSafresh1 # Restore globals. We need to do it like this, because setting one 3892*3d61058aSafresh1 # undefines the other. 3893*3d61058aSafresh1 3894*3d61058aSafresh1 if (defined $ab) { 3895*3d61058aSafresh1 $class -> accuracy($ab); 3896*3d61058aSafresh1 } else { 3897*3d61058aSafresh1 $class -> precision($pb); 3898*3d61058aSafresh1 } 3899*3d61058aSafresh1 3900*3d61058aSafresh1 $class -> upgrade($upg); 3901*3d61058aSafresh1 $class -> downgrade($dng); 3902e0680481Safresh1 3903e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 3904e0680481Safresh1 if defined($downgrade) && ($x -> is_int() || $x -> is_inf()); 39059f11ffb7Safresh1 $x; 39069f11ffb7Safresh1} 39079f11ffb7Safresh1 39089f11ffb7Safresh1sub bfac { 39099f11ffb7Safresh1 # (BFLOAT or num_str, BFLOAT or num_str) return BFLOAT 39109f11ffb7Safresh1 # compute factorial number, modifies first argument 39119f11ffb7Safresh1 39129f11ffb7Safresh1 # set up parameters 3913e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 39149f11ffb7Safresh1 39159f11ffb7Safresh1 # inf => inf 3916e0680481Safresh1 return $x if $x->modify('bfac'); 39179f11ffb7Safresh1 3918e0680481Safresh1 return $x -> bnan(@r) if $x->is_nan() || $x->is_inf("-"); 3919e0680481Safresh1 return $x -> binf("+", @r) if $x->is_inf("+"); 3920e0680481Safresh1 return $x -> bone(@r) if $x->is_zero() || $x->is_one(); 3921e0680481Safresh1 3922e0680481Safresh1 if ($x -> is_neg() || !$x -> is_int()) { 3923e0680481Safresh1 return $upgrade -> bfac($x, @r) if defined($upgrade); 3924e0680481Safresh1 return $x -> bnan(@r); 3925e0680481Safresh1 } 39269f11ffb7Safresh1 3927b46d8ef2Safresh1 if (! $LIB->_is_zero($x->{_e})) { 3928b46d8ef2Safresh1 $x->{_m} = $LIB->_lsft($x->{_m}, $x->{_e}, 10); # change 12e1 to 120e0 3929b46d8ef2Safresh1 $x->{_e} = $LIB->_zero(); # normalize 39309f11ffb7Safresh1 $x->{_es} = '+'; 39319f11ffb7Safresh1 } 3932b46d8ef2Safresh1 $x->{_m} = $LIB->_fac($x->{_m}); # calculate factorial 3933e0680481Safresh1 3934e0680481Safresh1 $x = $x->bnorm()->round(@r); # norm again and round result 3935e0680481Safresh1 3936e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade) 3937e0680481Safresh1 && ($x -> is_int() || $x -> is_inf()); 3938e0680481Safresh1 $x; 39399f11ffb7Safresh1} 39409f11ffb7Safresh1 39419f11ffb7Safresh1sub bdfac { 39429f11ffb7Safresh1 # compute double factorial 39439f11ffb7Safresh1 39449f11ffb7Safresh1 # set up parameters 3945e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 39469f11ffb7Safresh1 3947e0680481Safresh1 return $x if $x->modify('bdfac'); 39489f11ffb7Safresh1 3949e0680481Safresh1 return $x -> bnan(@r) if $x->is_nan() || $x->is_inf("-"); 3950e0680481Safresh1 return $x -> binf("+", @r) if $x->is_inf("+"); 3951e0680481Safresh1 3952e0680481Safresh1 if ($x <= -2 || !$x -> is_int()) { 3953e0680481Safresh1 return $upgrade -> bdfac($x, @r) if defined($upgrade); 3954e0680481Safresh1 return $x -> bnan(@r); 3955e0680481Safresh1 } 3956e0680481Safresh1 3957eac174f2Safresh1 return $x->bone() if $x <= 1; 39589f11ffb7Safresh1 3959b46d8ef2Safresh1 croak("bdfac() requires a newer version of the $LIB library.") 3960b46d8ef2Safresh1 unless $LIB->can('_dfac'); 39619f11ffb7Safresh1 3962b46d8ef2Safresh1 if (! $LIB->_is_zero($x->{_e})) { 3963b46d8ef2Safresh1 $x->{_m} = $LIB->_lsft($x->{_m}, $x->{_e}, 10); # change 12e1 to 120e0 3964b46d8ef2Safresh1 $x->{_e} = $LIB->_zero(); # normalize 39659f11ffb7Safresh1 $x->{_es} = '+'; 39669f11ffb7Safresh1 } 3967b46d8ef2Safresh1 $x->{_m} = $LIB->_dfac($x->{_m}); # calculate factorial 3968e0680481Safresh1 3969e0680481Safresh1 $x = $x->bnorm()->round(@r); # norm again and round result 3970e0680481Safresh1 3971e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 3972e0680481Safresh1 if defined($downgrade) && $x -> is_int(); 3973e0680481Safresh1 return $x; 39749f11ffb7Safresh1} 39759f11ffb7Safresh1 3976eac174f2Safresh1sub btfac { 3977eac174f2Safresh1 # compute triple factorial 3978eac174f2Safresh1 3979eac174f2Safresh1 # set up parameters 3980e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 3981eac174f2Safresh1 3982e0680481Safresh1 return $x if $x->modify('btfac'); 3983eac174f2Safresh1 3984e0680481Safresh1 return $x -> bnan(@r) if $x->is_nan() || $x->is_inf("-"); 3985e0680481Safresh1 return $x -> binf("+", @r) if $x->is_inf("+"); 3986e0680481Safresh1 3987e0680481Safresh1 if ($x <= -3 || !$x -> is_int()) { 3988e0680481Safresh1 return $upgrade -> btfac($x, @r) if defined($upgrade); 3989e0680481Safresh1 return $x -> bnan(@r); 3990e0680481Safresh1 } 3991eac174f2Safresh1 3992eac174f2Safresh1 my $k = $class -> new("3"); 3993e0680481Safresh1 return $x->bnan(@r) if $x <= -$k; 3994eac174f2Safresh1 3995eac174f2Safresh1 my $one = $class -> bone(); 3996e0680481Safresh1 return $x->bone(@r) if $x <= $one; 3997eac174f2Safresh1 3998eac174f2Safresh1 my $f = $x -> copy(); 3999eac174f2Safresh1 while ($f -> bsub($k) > $one) { 4000e0680481Safresh1 $x = $x -> bmul($f); 4001eac174f2Safresh1 } 4002e0680481Safresh1 4003e0680481Safresh1 $x = $x->round(@r); 4004e0680481Safresh1 4005e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 4006e0680481Safresh1 if defined($downgrade) && $x -> is_int(); 4007e0680481Safresh1 return $x; 4008eac174f2Safresh1} 4009eac174f2Safresh1 4010eac174f2Safresh1sub bmfac { 4011e0680481Safresh1 my ($class, $x, $k, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 4012e0680481Safresh1 ? (ref($_[0]), @_) 4013e0680481Safresh1 : objectify(2, @_); 4014eac174f2Safresh1 4015e0680481Safresh1 return $x if $x->modify('bmfac'); 4016eac174f2Safresh1 4017e0680481Safresh1 return $x -> bnan(@r) if $x->is_nan() || $x->is_inf("-") || !$k->is_pos(); 4018e0680481Safresh1 return $x -> binf("+", @r) if $x->is_inf("+"); 4019eac174f2Safresh1 4020e0680481Safresh1 if ($x <= -$k || !$x -> is_int() || 4021e0680481Safresh1 ($k -> is_finite() && !$k -> is_int())) 4022e0680481Safresh1 { 4023e0680481Safresh1 return $upgrade -> bmfac($x, $k, @r) if defined($upgrade); 4024e0680481Safresh1 return $x -> bnan(@r); 4025e0680481Safresh1 } 4026eac174f2Safresh1 4027eac174f2Safresh1 my $one = $class -> bone(); 4028e0680481Safresh1 return $x->bone(@r) if $x <= $one; 4029eac174f2Safresh1 4030eac174f2Safresh1 my $f = $x -> copy(); 4031eac174f2Safresh1 while ($f -> bsub($k) > $one) { 4032e0680481Safresh1 $x = $x -> bmul($f); 4033eac174f2Safresh1 } 4034e0680481Safresh1 4035e0680481Safresh1 $x = $x->round(@r); 4036e0680481Safresh1 4037e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) 4038e0680481Safresh1 if defined($downgrade) && $x -> is_int(); 4039e0680481Safresh1 return $x; 4040eac174f2Safresh1} 4041eac174f2Safresh1 40429f11ffb7Safresh1sub blsft { 4043*3d61058aSafresh1 # shift left by $y in base $b, i.e., multiply by $b ** $y 40449f11ffb7Safresh1 40459f11ffb7Safresh1 # set up parameters 4046e0680481Safresh1 my ($class, $x, $y, $b, @r) 4047e0680481Safresh1 = ref($_[0]) && ref($_[0]) eq ref($_[1]) && ref($_[1]) eq ref($_[2]) 4048e0680481Safresh1 ? (ref($_[0]), @_) 4049e0680481Safresh1 : objectify(2, @_); 40509f11ffb7Safresh1 40519f11ffb7Safresh1 return $x if $x -> modify('blsft'); 4052e0680481Safresh1 4053e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); 40549f11ffb7Safresh1 40559f11ffb7Safresh1 $b = 2 if !defined $b; 4056*3d61058aSafresh1 $b = $class -> new($b) 4057*3d61058aSafresh1 unless defined(blessed($b)) && $b -> isa(__PACKAGE__); 4058e0680481Safresh1 return $x -> bnan(@r) if $b -> is_nan(); 40599f11ffb7Safresh1 4060e0680481Safresh1 # There needs to be more checking for special cases here. Fixme! 40619f11ffb7Safresh1 40629f11ffb7Safresh1 # shift by a negative amount? 40639f11ffb7Safresh1 return $x -> brsft($y -> copy() -> babs(), $b) if $y -> {sign} =~ /^-/; 40649f11ffb7Safresh1 4065e0680481Safresh1 $x = $x -> bmul($b -> bpow($y), $r[0], $r[1], $r[2], $y); 4066e0680481Safresh1 4067e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade) 4068e0680481Safresh1 && ($x -> is_int() || $x -> is_inf() || $x -> is_nan()); 4069e0680481Safresh1 return $x; 40709f11ffb7Safresh1} 40719f11ffb7Safresh1 40729f11ffb7Safresh1sub brsft { 4073*3d61058aSafresh1 # shift right by $y in base $b, i.e., divide by $b ** $y 40749f11ffb7Safresh1 40759f11ffb7Safresh1 # set up parameters 4076e0680481Safresh1 my ($class, $x, $y, $b, @r) 4077e0680481Safresh1 = ref($_[0]) && ref($_[0]) eq ref($_[1]) && ref($_[1]) eq ref($_[2]) 4078e0680481Safresh1 ? (ref($_[0]), @_) 4079e0680481Safresh1 : objectify(2, @_); 40809f11ffb7Safresh1 40819f11ffb7Safresh1 return $x if $x -> modify('brsft'); 4082e0680481Safresh1 4083e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); 4084e0680481Safresh1 4085e0680481Safresh1 # There needs to be more checking for special cases here. Fixme! 40869f11ffb7Safresh1 40879f11ffb7Safresh1 $b = 2 if !defined $b; 4088*3d61058aSafresh1 $b = $class -> new($b) 4089*3d61058aSafresh1 unless defined(blessed($b)) && $b -> isa(__PACKAGE__); 4090e0680481Safresh1 return $x -> bnan(@r) if $b -> is_nan(); 40919f11ffb7Safresh1 40929f11ffb7Safresh1 # shift by a negative amount? 40939f11ffb7Safresh1 return $x -> blsft($y -> copy() -> babs(), $b) if $y -> {sign} =~ /^-/; 40949f11ffb7Safresh1 4095e0680481Safresh1 # call bdiv() 4096e0680481Safresh1 $x = $x -> bdiv($b -> bpow($y), $r[0], $r[1], $r[2], $y); 4097e0680481Safresh1 4098e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade) 4099e0680481Safresh1 && ($x -> is_int() || $x -> is_inf() || $x -> is_nan()); 4100e0680481Safresh1 return $x; 41019f11ffb7Safresh1} 41029f11ffb7Safresh1 41039f11ffb7Safresh1############################################################################### 41049f11ffb7Safresh1# Bitwise methods 41059f11ffb7Safresh1############################################################################### 41069f11ffb7Safresh1 4107*3d61058aSafresh1# Bitwise left shift. 4108*3d61058aSafresh1 4109*3d61058aSafresh1sub bblsft { 4110*3d61058aSafresh1 # We don't call objectify(), because the bitwise methods should not 4111*3d61058aSafresh1 # upgrade/downgrade, even when upgrading/downgrading is enabled. 4112*3d61058aSafresh1 4113*3d61058aSafresh1 my ($class, $x, $y, @r) = ref($_[0]) ? (ref($_[0]), @_) : @_; 4114*3d61058aSafresh1 4115*3d61058aSafresh1 my $xint = Math::BigInt -> bblsft($x, $y, @r); 4116*3d61058aSafresh1 4117*3d61058aSafresh1 # Temporarily disable downgrading. 4118*3d61058aSafresh1 4119*3d61058aSafresh1 my $dng = $class -> downgrade(); 4120*3d61058aSafresh1 $class -> downgrade(undef); 4121*3d61058aSafresh1 4122*3d61058aSafresh1 # convert to our class without downgrading. 4123*3d61058aSafresh1 4124*3d61058aSafresh1 my $xflt = $class -> new($xint); 4125*3d61058aSafresh1 4126*3d61058aSafresh1 # Reset downgrading. 4127*3d61058aSafresh1 4128*3d61058aSafresh1 $class -> downgrade($dng); 4129*3d61058aSafresh1 4130*3d61058aSafresh1 # If we are called as a class method, the first operand might not be an 4131*3d61058aSafresh1 # object of this class, so check. 4132*3d61058aSafresh1 4133*3d61058aSafresh1 if (defined(blessed($x)) && $x -> isa(__PACKAGE__)) { 4134*3d61058aSafresh1 $x -> {sign} = $xflt -> {sign}; 4135*3d61058aSafresh1 $x -> {_m} = $xflt -> {_m}; 4136*3d61058aSafresh1 $x -> {_es} = $xflt -> {_es}; 4137*3d61058aSafresh1 $x -> {_e} = $xflt -> {_e}; 4138*3d61058aSafresh1 } else { 4139*3d61058aSafresh1 $x = $xflt; 4140*3d61058aSafresh1 } 4141*3d61058aSafresh1 4142*3d61058aSafresh1 # Now we might downgrade. 4143*3d61058aSafresh1 4144*3d61058aSafresh1 return $downgrade -> new($x) if defined($downgrade); 4145*3d61058aSafresh1 $x -> round(@r); 4146*3d61058aSafresh1} 4147*3d61058aSafresh1 4148*3d61058aSafresh1# Bitwise right shift. 4149*3d61058aSafresh1 4150*3d61058aSafresh1sub bbrsft { 4151*3d61058aSafresh1 # We don't call objectify(), because the bitwise methods should not 4152*3d61058aSafresh1 # upgrade/downgrade, even when upgrading/downgrading is enabled. 4153*3d61058aSafresh1 4154*3d61058aSafresh1 my ($class, $x, $y, @r) = ref($_[0]) ? (ref($_[0]), @_) : @_; 4155*3d61058aSafresh1 4156*3d61058aSafresh1 my $xint = Math::BigInt -> bbrsft($x, $y, @r); 4157*3d61058aSafresh1 4158*3d61058aSafresh1 # Temporarily disable downgrading. 4159*3d61058aSafresh1 4160*3d61058aSafresh1 my $dng = $class -> downgrade(); 4161*3d61058aSafresh1 $class -> downgrade(undef); 4162*3d61058aSafresh1 4163*3d61058aSafresh1 # Convert to our class without downgrading. 4164*3d61058aSafresh1 4165*3d61058aSafresh1 my $xflt = $class -> new($xint); 4166*3d61058aSafresh1 4167*3d61058aSafresh1 # Reset downgrading. 4168*3d61058aSafresh1 4169*3d61058aSafresh1 $class -> downgrade($dng); 4170*3d61058aSafresh1 4171*3d61058aSafresh1 # If we are called as a class method, the first operand might not be an 4172*3d61058aSafresh1 # object of this class, so check. 4173*3d61058aSafresh1 4174*3d61058aSafresh1 if (defined(blessed($x)) && $x -> isa(__PACKAGE__)) { 4175*3d61058aSafresh1 $x -> {sign} = $xflt -> {sign}; 4176*3d61058aSafresh1 $x -> {_m} = $xflt -> {_m}; 4177*3d61058aSafresh1 $x -> {_es} = $xflt -> {_es}; 4178*3d61058aSafresh1 $x -> {_e} = $xflt -> {_e}; 4179*3d61058aSafresh1 } else { 4180*3d61058aSafresh1 $x = $xflt; 4181*3d61058aSafresh1 } 4182*3d61058aSafresh1 4183*3d61058aSafresh1 # Now we might downgrade. 4184*3d61058aSafresh1 4185*3d61058aSafresh1 return $downgrade -> new($x) if defined($downgrade); 4186*3d61058aSafresh1 $x -> round(@r); 4187*3d61058aSafresh1} 4188*3d61058aSafresh1 41899f11ffb7Safresh1sub band { 4190e0680481Safresh1 my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 4191e0680481Safresh1 ? (ref($_[0]), @_) 4192e0680481Safresh1 : objectify(2, @_); 41939f11ffb7Safresh1 41949f11ffb7Safresh1 return if $x -> modify('band'); 41959f11ffb7Safresh1 4196e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); 41979f11ffb7Safresh1 4198*3d61058aSafresh1 my $xint = $x -> as_int(); # to Math::BigInt 4199*3d61058aSafresh1 my $yint = $y -> as_int(); # to Math::BigInt 42009f11ffb7Safresh1 4201*3d61058aSafresh1 $xint = $xint -> band($yint); 4202e0680481Safresh1 4203*3d61058aSafresh1 return $xint -> round(@r) if defined $downgrade; 4204*3d61058aSafresh1 4205*3d61058aSafresh1 my $xflt = $class -> new($xint); # back to Math::BigFloat 4206*3d61058aSafresh1 $x -> {sign} = $xflt -> {sign}; 4207*3d61058aSafresh1 $x -> {_m} = $xflt -> {_m}; 4208*3d61058aSafresh1 $x -> {_es} = $xflt -> {_es}; 4209*3d61058aSafresh1 $x -> {_e} = $xflt -> {_e}; 42109f11ffb7Safresh1 42119f11ffb7Safresh1 return $x -> round(@r); 42129f11ffb7Safresh1} 42139f11ffb7Safresh1 42149f11ffb7Safresh1sub bior { 4215e0680481Safresh1 my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 4216e0680481Safresh1 ? (ref($_[0]), @_) 4217e0680481Safresh1 : objectify(2, @_); 42189f11ffb7Safresh1 42199f11ffb7Safresh1 return if $x -> modify('bior'); 42209f11ffb7Safresh1 4221e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); 42229f11ffb7Safresh1 4223*3d61058aSafresh1 my $xint = $x -> as_int(); # to Math::BigInt 4224*3d61058aSafresh1 my $yint = $y -> as_int(); # to Math::BigInt 42259f11ffb7Safresh1 4226*3d61058aSafresh1 $xint = $xint -> bior($yint); 4227e0680481Safresh1 4228*3d61058aSafresh1 return $xint -> round(@r) if defined $downgrade; 4229*3d61058aSafresh1 4230*3d61058aSafresh1 my $xflt = $class -> new($xint); # back to Math::BigFloat 4231*3d61058aSafresh1 $x -> {sign} = $xflt -> {sign}; 4232*3d61058aSafresh1 $x -> {_m} = $xflt -> {_m}; 4233*3d61058aSafresh1 $x -> {_es} = $xflt -> {_es}; 4234*3d61058aSafresh1 $x -> {_e} = $xflt -> {_e}; 42359f11ffb7Safresh1 42369f11ffb7Safresh1 return $x -> round(@r); 42379f11ffb7Safresh1} 42389f11ffb7Safresh1 42399f11ffb7Safresh1sub bxor { 4240e0680481Safresh1 my ($class, $x, $y, @r) = ref($_[0]) && ref($_[0]) eq ref($_[1]) 4241e0680481Safresh1 ? (ref($_[0]), @_) 4242e0680481Safresh1 : objectify(2, @_); 42439f11ffb7Safresh1 42449f11ffb7Safresh1 return if $x -> modify('bxor'); 42459f11ffb7Safresh1 4246e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan() || $y -> is_nan(); 42479f11ffb7Safresh1 4248*3d61058aSafresh1 my $xint = $x -> as_int(); # to Math::BigInt 4249*3d61058aSafresh1 my $yint = $y -> as_int(); # to Math::BigInt 42509f11ffb7Safresh1 4251*3d61058aSafresh1 $xint = $xint -> bxor($yint); 4252e0680481Safresh1 4253*3d61058aSafresh1 return $xint -> round(@r) if defined $downgrade; 4254*3d61058aSafresh1 4255*3d61058aSafresh1 my $xflt = $class -> new($xint); # back to Math::BigFloat 4256*3d61058aSafresh1 $x -> {sign} = $xflt -> {sign}; 4257*3d61058aSafresh1 $x -> {_m} = $xflt -> {_m}; 4258*3d61058aSafresh1 $x -> {_es} = $xflt -> {_es}; 4259*3d61058aSafresh1 $x -> {_e} = $xflt -> {_e}; 42609f11ffb7Safresh1 42619f11ffb7Safresh1 return $x -> round(@r); 42629f11ffb7Safresh1} 42639f11ffb7Safresh1 42649f11ffb7Safresh1sub bnot { 4265e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 42669f11ffb7Safresh1 42679f11ffb7Safresh1 return if $x -> modify('bnot'); 42689f11ffb7Safresh1 4269e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan(); 42709f11ffb7Safresh1 4271*3d61058aSafresh1 my $xint = $x -> as_int(); # to Math::BigInt 4272*3d61058aSafresh1 $xint = $xint -> bnot(); 42739f11ffb7Safresh1 4274*3d61058aSafresh1 return $xint -> round(@r) if defined $downgrade; 4275e0680481Safresh1 4276*3d61058aSafresh1 my $xflt = $class -> new($xint); # back to Math::BigFloat 4277*3d61058aSafresh1 $x -> {sign} = $xflt -> {sign}; 4278*3d61058aSafresh1 $x -> {_m} = $xflt -> {_m}; 4279*3d61058aSafresh1 $x -> {_es} = $xflt -> {_es}; 4280*3d61058aSafresh1 $x -> {_e} = $xflt -> {_e}; 42819f11ffb7Safresh1 42829f11ffb7Safresh1 return $x -> round(@r); 42839f11ffb7Safresh1} 42849f11ffb7Safresh1 42859f11ffb7Safresh1############################################################################### 42869f11ffb7Safresh1# Rounding methods 42879f11ffb7Safresh1############################################################################### 42889f11ffb7Safresh1 42899f11ffb7Safresh1sub bround { 42909f11ffb7Safresh1 # accuracy: preserve $N digits, and overwrite the rest with 0's 42919f11ffb7Safresh1 4292e0680481Safresh1 my ($class, $x, @a) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 4293e0680481Safresh1 4294e0680481Safresh1 if (($a[0] || 0) < 0) { 4295b46d8ef2Safresh1 croak('bround() needs positive accuracy'); 42969f11ffb7Safresh1 } 42979f11ffb7Safresh1 4298eac174f2Safresh1 return $x if $x->modify('bround'); 42999f11ffb7Safresh1 4300e0680481Safresh1 my ($scale, $mode) = $x->_scale_a(@a); 4301eac174f2Safresh1 if (!defined $scale) { # no-op 4302eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade) 4303eac174f2Safresh1 && ($x->is_int() || $x->is_inf() || $x->is_nan()); 4304eac174f2Safresh1 return $x; 4305eac174f2Safresh1 } 4306eac174f2Safresh1 4307*3d61058aSafresh1 # Scale is now either $x->{accuracy}, $accuracy, or the input argument. Test 4308eac174f2Safresh1 # whether $x already has lower accuracy, do nothing in this case but do 4309eac174f2Safresh1 # round if the accuracy is the same, since a math operation might want to 4310eac174f2Safresh1 # round a number with A=5 to 5 digits afterwards again 4311eac174f2Safresh1 4312*3d61058aSafresh1 if (defined $x->{accuracy} && $x->{accuracy} < $scale) { 4313eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade) 4314eac174f2Safresh1 && ($x->is_int() || $x->is_inf() || $x->is_nan()); 4315eac174f2Safresh1 return $x; 4316eac174f2Safresh1 } 43179f11ffb7Safresh1 43189f11ffb7Safresh1 # scale < 0 makes no sense 43199f11ffb7Safresh1 # scale == 0 => keep all digits 43209f11ffb7Safresh1 # never round a +-inf, NaN 4321eac174f2Safresh1 4322eac174f2Safresh1 if ($scale <= 0 || $x->{sign} !~ /^[+-]$/) { 4323eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade) 4324eac174f2Safresh1 && ($x->is_int() || $x->is_inf() || $x->is_nan()); 4325eac174f2Safresh1 return $x; 4326eac174f2Safresh1 } 43279f11ffb7Safresh1 43289f11ffb7Safresh1 # 1: never round a 0 43299f11ffb7Safresh1 # 2: if we should keep more digits than the mantissa has, do nothing 4330b46d8ef2Safresh1 if ($x->is_zero() || $LIB->_len($x->{_m}) <= $scale) { 4331*3d61058aSafresh1 $x->{accuracy} = $scale if !defined $x->{accuracy} || $x->{accuracy} > $scale; 4332eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade) 4333eac174f2Safresh1 && ($x->is_int() || $x->is_inf() || $x->is_nan()); 43349f11ffb7Safresh1 return $x; 43359f11ffb7Safresh1 } 43369f11ffb7Safresh1 43379f11ffb7Safresh1 # pass sign to bround for '+inf' and '-inf' rounding modes 43389f11ffb7Safresh1 my $m = bless { sign => $x->{sign}, value => $x->{_m} }, 'Math::BigInt'; 43399f11ffb7Safresh1 4340e0680481Safresh1 $m = $m->bround($scale, $mode); # round mantissa 43419f11ffb7Safresh1 $x->{_m} = $m->{value}; # get our mantissa back 4342*3d61058aSafresh1 $x->{accuracy} = $scale; # remember rounding 4343*3d61058aSafresh1 $x->{precision} = undef; # and clear P 4344eac174f2Safresh1 4345eac174f2Safresh1 # bnorm() downgrades if necessary, so no need to check whether to downgrade. 43469f11ffb7Safresh1 $x->bnorm(); # del trailing zeros gen. by bround() 43479f11ffb7Safresh1} 43489f11ffb7Safresh1 43499f11ffb7Safresh1sub bfround { 43509f11ffb7Safresh1 # precision: round to the $Nth digit left (+$n) or right (-$n) from the '.' 43519f11ffb7Safresh1 # $n == 0 means round to integer 43529f11ffb7Safresh1 # expects and returns normalized numbers! 4353e0680481Safresh1 4354e0680481Safresh1 my ($class, $x, @p) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 43559f11ffb7Safresh1 4356eac174f2Safresh1 return $x if $x->modify('bfround'); # no-op 43579f11ffb7Safresh1 4358e0680481Safresh1 my ($scale, $mode) = $x->_scale_p(@p); 4359eac174f2Safresh1 if (!defined $scale) { 4360eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade) 4361eac174f2Safresh1 && ($x->is_int() || $x->is_inf() || $x->is_nan()); 43629f11ffb7Safresh1 return $x; 43639f11ffb7Safresh1 } 4364eac174f2Safresh1 4365eac174f2Safresh1 # never round a 0, +-inf, NaN 4366eac174f2Safresh1 4367eac174f2Safresh1 if ($x->is_zero()) { 4368*3d61058aSafresh1 $x->{precision} = $scale if !defined $x->{precision} || $x->{precision} < $scale; # -3 < -2 4369eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade) 4370eac174f2Safresh1 && ($x->is_int() || $x->is_inf() || $x->is_nan()); 4371eac174f2Safresh1 return $x; 4372eac174f2Safresh1 } 4373eac174f2Safresh1 4374eac174f2Safresh1 if ($x->{sign} !~ /^[+-]$/) { 4375eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade) 4376eac174f2Safresh1 && ($x->is_int() || $x->is_inf() || $x->is_nan()); 4377eac174f2Safresh1 return $x; 4378eac174f2Safresh1 } 43799f11ffb7Safresh1 43809f11ffb7Safresh1 # don't round if x already has lower precision 4381*3d61058aSafresh1 if (defined $x->{precision} && $x->{precision} < 0 && $scale < $x->{precision}) { 4382eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade) 4383eac174f2Safresh1 && ($x->is_int() || $x->is_inf() || $x->is_nan()); 4384eac174f2Safresh1 return $x; 4385eac174f2Safresh1 } 43869f11ffb7Safresh1 4387*3d61058aSafresh1 $x->{precision} = $scale; # remember round in any case 4388*3d61058aSafresh1 $x->{accuracy} = undef; # and clear A 43899f11ffb7Safresh1 if ($scale < 0) { 43909f11ffb7Safresh1 # round right from the '.' 43919f11ffb7Safresh1 4392eac174f2Safresh1 if ($x->{_es} eq '+') { # e >= 0 => nothing to round 4393eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade) 4394eac174f2Safresh1 && ($x->is_int() || $x->is_inf() || $x->is_nan()); 4395eac174f2Safresh1 return $x; 4396eac174f2Safresh1 } 43979f11ffb7Safresh1 43989f11ffb7Safresh1 $scale = -$scale; # positive for simplicity 4399b46d8ef2Safresh1 my $len = $LIB->_len($x->{_m}); # length of mantissa 44009f11ffb7Safresh1 44019f11ffb7Safresh1 # the following poses a restriction on _e, but if _e is bigger than a 44029f11ffb7Safresh1 # scalar, you got other problems (memory etc) anyway 4403b46d8ef2Safresh1 my $dad = -(0+ ($x->{_es}.$LIB->_num($x->{_e}))); # digits after dot 44049f11ffb7Safresh1 my $zad = 0; # zeros after dot 44059f11ffb7Safresh1 $zad = $dad - $len if (-$dad < -$len); # for 0.00..00xxx style 44069f11ffb7Safresh1 44079f11ffb7Safresh1 # print "scale $scale dad $dad zad $zad len $len\n"; 44089f11ffb7Safresh1 # number bsstr len zad dad 44099f11ffb7Safresh1 # 0.123 123e-3 3 0 3 44109f11ffb7Safresh1 # 0.0123 123e-4 3 1 4 44119f11ffb7Safresh1 # 0.001 1e-3 1 2 3 44129f11ffb7Safresh1 # 1.23 123e-2 3 0 2 44139f11ffb7Safresh1 # 1.2345 12345e-4 5 0 4 44149f11ffb7Safresh1 44159f11ffb7Safresh1 # do not round after/right of the $dad 4416eac174f2Safresh1 4417eac174f2Safresh1 if ($scale > $dad) { # 0.123, scale >= 3 => exit 4418eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade) 4419eac174f2Safresh1 && ($x->is_int() || $x->is_inf() || $x->is_nan()); 4420eac174f2Safresh1 return $x; 4421eac174f2Safresh1 } 44229f11ffb7Safresh1 44239f11ffb7Safresh1 # round to zero if rounding inside the $zad, but not for last zero like: 4424e0680481Safresh1 # 0.0065, scale -2, round last '0' with following '65' (scale == zad 4425e0680481Safresh1 # case) 4426eac174f2Safresh1 if ($scale < $zad) { 4427eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade) 4428eac174f2Safresh1 && ($x->is_int() || $x->is_inf() || $x->is_nan()); 4429eac174f2Safresh1 return $x->bzero(); 4430eac174f2Safresh1 } 4431eac174f2Safresh1 4432eac174f2Safresh1 if ($scale == $zad) { # for 0.006, scale -3 and trunc 44339f11ffb7Safresh1 $scale = -$len; 44349f11ffb7Safresh1 } else { 44359f11ffb7Safresh1 # adjust round-point to be inside mantissa 44369f11ffb7Safresh1 if ($zad != 0) { 44379f11ffb7Safresh1 $scale = $scale-$zad; 44389f11ffb7Safresh1 } else { 44399f11ffb7Safresh1 my $dbd = $len - $dad; 44409f11ffb7Safresh1 $dbd = 0 if $dbd < 0; # digits before dot 44419f11ffb7Safresh1 $scale = $dbd+$scale; 44429f11ffb7Safresh1 } 44439f11ffb7Safresh1 } 44449f11ffb7Safresh1 } else { 44459f11ffb7Safresh1 # round left from the '.' 44469f11ffb7Safresh1 44479f11ffb7Safresh1 # 123 => 100 means length(123) = 3 - $scale (2) => 1 44489f11ffb7Safresh1 4449b46d8ef2Safresh1 my $dbt = $LIB->_len($x->{_m}); 44509f11ffb7Safresh1 # digits before dot 4451b46d8ef2Safresh1 my $dbd = $dbt + ($x->{_es} . $LIB->_num($x->{_e})); 44529f11ffb7Safresh1 # should be the same, so treat it as this 44539f11ffb7Safresh1 $scale = 1 if $scale == 0; 44549f11ffb7Safresh1 # shortcut if already integer 4455eac174f2Safresh1 if ($scale == 1 && $dbt <= $dbd) { 4456eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade) 4457eac174f2Safresh1 && ($x->is_int() || $x->is_inf() || $x->is_nan()); 4458eac174f2Safresh1 return $x; 4459eac174f2Safresh1 } 44609f11ffb7Safresh1 # maximum digits before dot 44619f11ffb7Safresh1 ++$dbd; 44629f11ffb7Safresh1 44639f11ffb7Safresh1 if ($scale > $dbd) { 44649f11ffb7Safresh1 # not enough digits before dot, so round to zero 4465eac174f2Safresh1 return $downgrade -> new($x) if defined($downgrade); 44669f11ffb7Safresh1 return $x->bzero; 44679f11ffb7Safresh1 } elsif ($scale == $dbd) { 44689f11ffb7Safresh1 # maximum 44699f11ffb7Safresh1 $scale = -$dbt; 44709f11ffb7Safresh1 } else { 44719f11ffb7Safresh1 $scale = $dbd - $scale; 44729f11ffb7Safresh1 } 44739f11ffb7Safresh1 } 4474eac174f2Safresh1 44759f11ffb7Safresh1 # pass sign to bround for rounding modes '+inf' and '-inf' 44769f11ffb7Safresh1 my $m = bless { sign => $x->{sign}, value => $x->{_m} }, 'Math::BigInt'; 4477e0680481Safresh1 $m = $m->bround($scale, $mode); 44789f11ffb7Safresh1 $x->{_m} = $m->{value}; # get our mantissa back 4479eac174f2Safresh1 4480eac174f2Safresh1 # bnorm() downgrades if necessary, so no need to check whether to downgrade. 44819f11ffb7Safresh1 $x->bnorm(); 44829f11ffb7Safresh1} 44839f11ffb7Safresh1 44849f11ffb7Safresh1sub bfloor { 44859f11ffb7Safresh1 # round towards minus infinity 4486eac174f2Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 44879f11ffb7Safresh1 44889f11ffb7Safresh1 return $x if $x->modify('bfloor'); 44899f11ffb7Safresh1 4490e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan(); 4491e0680481Safresh1 4492eac174f2Safresh1 if ($x->{sign} =~ /^[+-]$/) { 4493eac174f2Safresh1 # if $x has digits after dot, remove them 44949f11ffb7Safresh1 if ($x->{_es} eq '-') { 4495eac174f2Safresh1 $x->{_m} = $LIB->_rsft($x->{_m}, $x->{_e}, 10); 4496eac174f2Safresh1 $x->{_e} = $LIB->_zero(); 4497eac174f2Safresh1 $x->{_es} = '+'; 4498eac174f2Safresh1 # increment if negative 4499eac174f2Safresh1 $x->{_m} = $LIB->_inc($x->{_m}) if $x->{sign} eq '-'; 45009f11ffb7Safresh1 } 4501e0680481Safresh1 $x = $x->round(@r); 4502eac174f2Safresh1 } 4503e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade); 4504eac174f2Safresh1 return $x; 45059f11ffb7Safresh1} 45069f11ffb7Safresh1 45079f11ffb7Safresh1sub bceil { 45089f11ffb7Safresh1 # round towards plus infinity 4509eac174f2Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 45109f11ffb7Safresh1 45119f11ffb7Safresh1 return $x if $x->modify('bceil'); 45129f11ffb7Safresh1 4513e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan(); 4514e0680481Safresh1 4515eac174f2Safresh1 # if $x has digits after dot, remove them 4516eac174f2Safresh1 if ($x->{sign} =~ /^[+-]$/) { 45179f11ffb7Safresh1 if ($x->{_es} eq '-') { 4518eac174f2Safresh1 $x->{_m} = $LIB->_rsft($x->{_m}, $x->{_e}, 10); 4519eac174f2Safresh1 $x->{_e} = $LIB->_zero(); 4520eac174f2Safresh1 $x->{_es} = '+'; 45219f11ffb7Safresh1 if ($x->{sign} eq '+') { 4522b46d8ef2Safresh1 $x->{_m} = $LIB->_inc($x->{_m}); # increment if positive 45239f11ffb7Safresh1 } else { 4524b46d8ef2Safresh1 $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # avoid -0 45259f11ffb7Safresh1 } 45269f11ffb7Safresh1 } 4527e0680481Safresh1 $x = $x->round(@r); 4528eac174f2Safresh1 } 4529eac174f2Safresh1 4530e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade); 4531eac174f2Safresh1 return $x; 45329f11ffb7Safresh1} 45339f11ffb7Safresh1 45349f11ffb7Safresh1sub bint { 45359f11ffb7Safresh1 # round towards zero 4536eac174f2Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 45379f11ffb7Safresh1 45389f11ffb7Safresh1 return $x if $x->modify('bint'); 45399f11ffb7Safresh1 4540e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan(); 4541e0680481Safresh1 4542eac174f2Safresh1 if ($x->{sign} =~ /^[+-]$/) { 45439f11ffb7Safresh1 # if $x has digits after the decimal point 45449f11ffb7Safresh1 if ($x->{_es} eq '-') { 4545e0680481Safresh1 $x->{_m} = $LIB->_rsft($x->{_m}, $x->{_e}, 10); # remove frac part 4546b46d8ef2Safresh1 $x->{_e} = $LIB->_zero(); # truncate/normalize 45479f11ffb7Safresh1 $x->{_es} = '+'; # abs e 4548b46d8ef2Safresh1 $x->{sign} = '+' if $LIB->_is_zero($x->{_m}); # avoid -0 45499f11ffb7Safresh1 } 4550e0680481Safresh1 $x = $x->round(@r); 4551eac174f2Safresh1 } 4552eac174f2Safresh1 4553e0680481Safresh1 return $downgrade -> new($x -> bdstr(), @r) if defined($downgrade); 4554eac174f2Safresh1 return $x; 45559f11ffb7Safresh1} 45569f11ffb7Safresh1 45579f11ffb7Safresh1############################################################################### 45589f11ffb7Safresh1# Other mathematical methods 45599f11ffb7Safresh1############################################################################### 45609f11ffb7Safresh1 45619f11ffb7Safresh1sub bgcd { 45629f11ffb7Safresh1 # (BINT or num_str, BINT or num_str) return BINT 45639f11ffb7Safresh1 # does not modify arguments, but returns new object 45649f11ffb7Safresh1 4565e0680481Safresh1 # Class::method(...) -> Class->method(...) 4566e0680481Safresh1 unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || 4567e0680481Safresh1 $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) 4568e0680481Safresh1 { 4569e0680481Safresh1 #carp "Using ", (caller(0))[3], "() as a function is deprecated;", 4570e0680481Safresh1 # " use is as a method instead"; 4571e0680481Safresh1 unshift @_, __PACKAGE__; 4572e0680481Safresh1 } 45739f11ffb7Safresh1 45749f11ffb7Safresh1 my ($class, @args) = objectify(0, @_); 45759f11ffb7Safresh1 45769f11ffb7Safresh1 my $x = shift @args; 4577*3d61058aSafresh1 $x = defined(blessed($x)) && $x -> isa(__PACKAGE__) ? $x -> copy() 4578*3d61058aSafresh1 : $class -> new($x); 45799f11ffb7Safresh1 return $class->bnan() unless $x -> is_int(); 45809f11ffb7Safresh1 45819f11ffb7Safresh1 while (@args) { 45829f11ffb7Safresh1 my $y = shift @args; 4583*3d61058aSafresh1 $y = $class->new($y) 4584*3d61058aSafresh1 unless defined(blessed($y)) && $y -> isa(__PACKAGE__); 45859f11ffb7Safresh1 return $class->bnan() unless $y -> is_int(); 45869f11ffb7Safresh1 45879f11ffb7Safresh1 # greatest common divisor 45889f11ffb7Safresh1 while (! $y->is_zero()) { 45899f11ffb7Safresh1 ($x, $y) = ($y->copy(), $x->copy()->bmod($y)); 45909f11ffb7Safresh1 } 45919f11ffb7Safresh1 45929f11ffb7Safresh1 last if $x -> is_one(); 45939f11ffb7Safresh1 } 4594e0680481Safresh1 $x = $x -> babs(); 4595e0680481Safresh1 4596e0680481Safresh1 return $downgrade -> new($x) 4597e0680481Safresh1 if defined $downgrade && $x->is_int(); 4598e0680481Safresh1 return $x; 45999f11ffb7Safresh1} 46009f11ffb7Safresh1 46019f11ffb7Safresh1sub blcm { 46029f11ffb7Safresh1 # (BFLOAT or num_str, BFLOAT or num_str) return BFLOAT 46039f11ffb7Safresh1 # does not modify arguments, but returns new object 46049f11ffb7Safresh1 # Least Common Multiple 46059f11ffb7Safresh1 4606e0680481Safresh1 # Class::method(...) -> Class->method(...) 4607e0680481Safresh1 unless (@_ && (defined(blessed($_[0])) && $_[0] -> isa(__PACKAGE__) || 4608e0680481Safresh1 $_[0] =~ /^[a-z]\w*(?:::[a-z]\w*)*$/i)) 4609e0680481Safresh1 { 4610e0680481Safresh1 #carp "Using ", (caller(0))[3], "() as a function is deprecated;", 4611e0680481Safresh1 # " use is as a method instead"; 4612e0680481Safresh1 unshift @_, __PACKAGE__; 4613e0680481Safresh1 } 46149f11ffb7Safresh1 46159f11ffb7Safresh1 my ($class, @args) = objectify(0, @_); 46169f11ffb7Safresh1 46179f11ffb7Safresh1 my $x = shift @args; 4618*3d61058aSafresh1 $x = defined(blessed($x)) && $x -> isa(__PACKAGE__) ? $x -> copy() 4619*3d61058aSafresh1 : $class -> new($x); 46209f11ffb7Safresh1 return $class->bnan() if $x->{sign} !~ /^[+-]$/; # x NaN? 46219f11ffb7Safresh1 46229f11ffb7Safresh1 while (@args) { 46239f11ffb7Safresh1 my $y = shift @args; 4624*3d61058aSafresh1 $y = $class -> new($y) 4625*3d61058aSafresh1 unless defined(blessed($y)) && $y -> isa(__PACKAGE__); 46269f11ffb7Safresh1 return $x->bnan() unless $y -> is_int(); 46279f11ffb7Safresh1 my $gcd = $x -> bgcd($y); 4628e0680481Safresh1 $x = $x -> bdiv($gcd) -> bmul($y); 46299f11ffb7Safresh1 } 46309f11ffb7Safresh1 4631e0680481Safresh1 $x = $x -> babs(); 4632e0680481Safresh1 4633e0680481Safresh1 return $downgrade -> new($x) 4634e0680481Safresh1 if defined $downgrade && $x->is_int(); 4635e0680481Safresh1 return $x; 46369f11ffb7Safresh1} 46379f11ffb7Safresh1 46389f11ffb7Safresh1############################################################################### 46399f11ffb7Safresh1# Object property methods 46409f11ffb7Safresh1############################################################################### 46419f11ffb7Safresh1 46429f11ffb7Safresh1sub length { 4643e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 4644e0680481Safresh1 4645e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 46469f11ffb7Safresh1 4647b46d8ef2Safresh1 return 1 if $LIB->_is_zero($x->{_m}); 46489f11ffb7Safresh1 4649b46d8ef2Safresh1 my $len = $LIB->_len($x->{_m}); 4650b46d8ef2Safresh1 $len += $LIB->_num($x->{_e}) if $x->{_es} eq '+'; 46519f11ffb7Safresh1 if (wantarray()) { 46529f11ffb7Safresh1 my $t = 0; 4653b46d8ef2Safresh1 $t = $LIB->_num($x->{_e}) if $x->{_es} eq '-'; 46549f11ffb7Safresh1 return ($len, $t); 46559f11ffb7Safresh1 } 46569f11ffb7Safresh1 $len; 46579f11ffb7Safresh1} 46589f11ffb7Safresh1 46599f11ffb7Safresh1sub mantissa { 46609f11ffb7Safresh1 # return a copy of the mantissa 4661e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 4662e0680481Safresh1 4663e0680481Safresh1 # The following line causes a lot of noise in the test suits for 4664e0680481Safresh1 # the Math-BigRat and bignum distributions. Fixme! 4665e0680481Safresh1 #carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 4666e0680481Safresh1 4667e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan(); 46689f11ffb7Safresh1 46699f11ffb7Safresh1 if ($x->{sign} !~ /^[+-]$/) { 46709f11ffb7Safresh1 my $s = $x->{sign}; 467156d68f1eSafresh1 $s =~ s/^\+//; 46729f11ffb7Safresh1 return Math::BigInt->new($s, undef, undef); # -inf, +inf => +inf 46739f11ffb7Safresh1 } 4674b46d8ef2Safresh1 my $m = Math::BigInt->new($LIB->_str($x->{_m}), undef, undef); 4675e0680481Safresh1 $m = $m->bneg() if $x->{sign} eq '-'; 46769f11ffb7Safresh1 $m; 46779f11ffb7Safresh1} 46789f11ffb7Safresh1 46799f11ffb7Safresh1sub exponent { 46809f11ffb7Safresh1 # return a copy of the exponent 4681e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 4682e0680481Safresh1 4683e0680481Safresh1 # The following line causes a lot of noise in the test suits for 4684e0680481Safresh1 # the Math-BigRat and bignum distributions. Fixme! 4685e0680481Safresh1 #carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 4686e0680481Safresh1 4687e0680481Safresh1 return $x -> bnan(@r) if $x -> is_nan(); 46889f11ffb7Safresh1 46899f11ffb7Safresh1 if ($x->{sign} !~ /^[+-]$/) { 46909f11ffb7Safresh1 my $s = $x->{sign}; 46919f11ffb7Safresh1 $s =~ s/^[+-]//; 46929f11ffb7Safresh1 return Math::BigInt->new($s, undef, undef); # -inf, +inf => +inf 46939f11ffb7Safresh1 } 4694b46d8ef2Safresh1 Math::BigInt->new($x->{_es} . $LIB->_str($x->{_e}), undef, undef); 46959f11ffb7Safresh1} 46969f11ffb7Safresh1 46979f11ffb7Safresh1sub parts { 46989f11ffb7Safresh1 # return a copy of both the exponent and the mantissa 4699e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 4700e0680481Safresh1 4701e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 47029f11ffb7Safresh1 47039f11ffb7Safresh1 if ($x->{sign} !~ /^[+-]$/) { 47049f11ffb7Safresh1 my $s = $x->{sign}; 470556d68f1eSafresh1 $s =~ s/^\+//; 47069f11ffb7Safresh1 my $se = $s; 470756d68f1eSafresh1 $se =~ s/^-//; 4708e0680481Safresh1 # +inf => inf and -inf, +inf => inf 4709e0680481Safresh1 return ($class->new($s), $class->new($se)); 47109f11ffb7Safresh1 } 47119f11ffb7Safresh1 my $m = Math::BigInt->bzero(); 4712b46d8ef2Safresh1 $m->{value} = $LIB->_copy($x->{_m}); 4713e0680481Safresh1 $m = $m->bneg() if $x->{sign} eq '-'; 4714b46d8ef2Safresh1 ($m, Math::BigInt->new($x->{_es} . $LIB->_num($x->{_e}))); 47159f11ffb7Safresh1} 47169f11ffb7Safresh1 4717e0680481Safresh1# Parts used for scientific notation with significand/mantissa and exponent as 4718e0680481Safresh1# integers. E.g., "12345.6789" is returned as "123456789" (mantissa) and "-4" 4719e0680481Safresh1# (exponent). 47209f11ffb7Safresh1 4721e0680481Safresh1sub sparts { 4722e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 4723e0680481Safresh1 4724e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 47259f11ffb7Safresh1 47269f11ffb7Safresh1 # Not-a-number. 47279f11ffb7Safresh1 4728e0680481Safresh1 if ($x -> is_nan()) { 4729e0680481Safresh1 my $mant = $class -> bnan(); # mantissa 47309f11ffb7Safresh1 return $mant unless wantarray; # scalar context 47319f11ffb7Safresh1 my $expo = $class -> bnan(); # exponent 47329f11ffb7Safresh1 return ($mant, $expo); # list context 47339f11ffb7Safresh1 } 47349f11ffb7Safresh1 47359f11ffb7Safresh1 # Infinity. 47369f11ffb7Safresh1 4737e0680481Safresh1 if ($x -> is_inf()) { 4738e0680481Safresh1 my $mant = $class -> binf($x->{sign}); # mantissa 47399f11ffb7Safresh1 return $mant unless wantarray; # scalar context 47409f11ffb7Safresh1 my $expo = $class -> binf('+'); # exponent 47419f11ffb7Safresh1 return ($mant, $expo); # list context 47429f11ffb7Safresh1 } 47439f11ffb7Safresh1 47449f11ffb7Safresh1 # Finite number. 47459f11ffb7Safresh1 4746*3d61058aSafresh1 my $mant = $class -> new($x); 4747e0680481Safresh1 $mant->{_es} = '+'; 4748e0680481Safresh1 $mant->{_e} = $LIB->_zero(); 4749e0680481Safresh1 $mant = $downgrade -> new($mant) if defined $downgrade; 47509f11ffb7Safresh1 return $mant unless wantarray; 47519f11ffb7Safresh1 4752*3d61058aSafresh1 my $expo = $class -> new($x -> {_es} . $LIB->_str($x -> {_e})); 4753e0680481Safresh1 $expo = $downgrade -> new($expo) if defined $downgrade; 47549f11ffb7Safresh1 return ($mant, $expo); 47559f11ffb7Safresh1} 47569f11ffb7Safresh1 4757e0680481Safresh1# Parts used for normalized notation with significand/mantissa as either 0 or a 4758e0680481Safresh1# number in the semi-open interval [1,10). E.g., "12345.6789" is returned as 4759e0680481Safresh1# "1.23456789" and "4". 4760e0680481Safresh1 47619f11ffb7Safresh1sub nparts { 4762e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 47639f11ffb7Safresh1 4764e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 47659f11ffb7Safresh1 4766e0680481Safresh1 # Not-a-number and Infinity. 47679f11ffb7Safresh1 4768e0680481Safresh1 return $x -> sparts() if $x -> is_nan() || $x -> is_inf(); 47699f11ffb7Safresh1 47709f11ffb7Safresh1 # Finite number. 47719f11ffb7Safresh1 4772e0680481Safresh1 my ($mant, $expo) = $x -> sparts(); 47739f11ffb7Safresh1 47749f11ffb7Safresh1 if ($mant -> bcmp(0)) { 47759f11ffb7Safresh1 my ($ndigtot, $ndigfrac) = $mant -> length(); 47769f11ffb7Safresh1 my $expo10adj = $ndigtot - $ndigfrac - 1; 47779f11ffb7Safresh1 4778e0680481Safresh1 if ($expo10adj > 0) { # if mantissa is not an integer 4779e0680481Safresh1 $mant = $mant -> brsft($expo10adj, 10); 47809f11ffb7Safresh1 return $mant unless wantarray; 4781e0680481Safresh1 $expo = $expo -> badd($expo10adj); 47829f11ffb7Safresh1 return ($mant, $expo); 47839f11ffb7Safresh1 } 47849f11ffb7Safresh1 } 47859f11ffb7Safresh1 47869f11ffb7Safresh1 return $mant unless wantarray; 47879f11ffb7Safresh1 return ($mant, $expo); 47889f11ffb7Safresh1} 47899f11ffb7Safresh1 4790e0680481Safresh1# Parts used for engineering notation with significand/mantissa as either 0 or a 4791e0680481Safresh1# number in the semi-open interval [1,1000) and the exponent is a multiple of 3. 4792e0680481Safresh1# E.g., "12345.6789" is returned as "12.3456789" and "3". 4793e0680481Safresh1 47949f11ffb7Safresh1sub eparts { 4795e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 47969f11ffb7Safresh1 4797e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 47989f11ffb7Safresh1 47999f11ffb7Safresh1 # Not-a-number and Infinity. 48009f11ffb7Safresh1 4801e0680481Safresh1 return $x -> sparts() if $x -> is_nan() || $x -> is_inf(); 48029f11ffb7Safresh1 48039f11ffb7Safresh1 # Finite number. 48049f11ffb7Safresh1 4805e0680481Safresh1 my ($mant, $expo) = $x -> nparts(); 48069f11ffb7Safresh1 48079f11ffb7Safresh1 my $c = $expo -> copy() -> bmod(3); 4808e0680481Safresh1 $mant = $mant -> blsft($c, 10); 48099f11ffb7Safresh1 return $mant unless wantarray; 48109f11ffb7Safresh1 4811e0680481Safresh1 $expo = $expo -> bsub($c); 48129f11ffb7Safresh1 return ($mant, $expo); 48139f11ffb7Safresh1} 48149f11ffb7Safresh1 4815e0680481Safresh1# Parts used for decimal notation, e.g., "12345.6789" is returned as "12345" 4816e0680481Safresh1# (integer part) and "0.6789" (fraction part). 4817e0680481Safresh1 48189f11ffb7Safresh1sub dparts { 4819e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 48209f11ffb7Safresh1 4821e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 48229f11ffb7Safresh1 4823e0680481Safresh1 # Not-a-number. 48249f11ffb7Safresh1 4825e0680481Safresh1 if ($x -> is_nan()) { 4826e0680481Safresh1 my $int = $class -> bnan(); 4827e0680481Safresh1 return $int unless wantarray; 4828e0680481Safresh1 my $frc = $class -> bzero(); # or NaN? 4829e0680481Safresh1 return ($int, $frc); 4830e0680481Safresh1 } 4831e0680481Safresh1 4832e0680481Safresh1 # Infinity. 4833e0680481Safresh1 4834e0680481Safresh1 if ($x -> is_inf()) { 4835e0680481Safresh1 my $int = $class -> binf($x->{sign}); 48369f11ffb7Safresh1 return $int unless wantarray; 48379f11ffb7Safresh1 my $frc = $class -> bzero(); 48389f11ffb7Safresh1 return ($int, $frc); 48399f11ffb7Safresh1 } 48409f11ffb7Safresh1 4841e0680481Safresh1 # Finite number. 48429f11ffb7Safresh1 4843e0680481Safresh1 my $int = $x -> copy(); 4844e0680481Safresh1 my $frc; 48459f11ffb7Safresh1 4846e0680481Safresh1 # If the input is an integer. 4847e0680481Safresh1 4848e0680481Safresh1 if ($int->{_es} eq '+') { 4849e0680481Safresh1 $frc = $class -> bzero(); 4850e0680481Safresh1 } 4851e0680481Safresh1 4852e0680481Safresh1 # If the input has a fraction part 4853e0680481Safresh1 4854e0680481Safresh1 else { 4855b46d8ef2Safresh1 $int->{_m} = $LIB -> _rsft($int->{_m}, $int->{_e}, 10); 4856b46d8ef2Safresh1 $int->{_e} = $LIB -> _zero(); 48579f11ffb7Safresh1 $int->{_es} = '+'; 4858b46d8ef2Safresh1 $int->{sign} = '+' if $LIB->_is_zero($int->{_m}); # avoid -0 48599f11ffb7Safresh1 return $int unless wantarray; 4860e0680481Safresh1 $frc = $x -> copy() -> bsub($int); 48619f11ffb7Safresh1 return ($int, $frc); 48629f11ffb7Safresh1 } 48639f11ffb7Safresh1 4864e0680481Safresh1 $int = $downgrade -> new($int) if defined $downgrade; 48659f11ffb7Safresh1 return $int unless wantarray; 4866e0680481Safresh1 return $int, $frc; 48679f11ffb7Safresh1} 48689f11ffb7Safresh1 4869e0680481Safresh1# Fractional parts with the numerator and denominator as integers. E.g., 4870e0680481Safresh1# "123.4375" is returned as "1975" and "16". 4871e0680481Safresh1 4872eac174f2Safresh1sub fparts { 4873e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 4874eac174f2Safresh1 4875e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 4876eac174f2Safresh1 4877e0680481Safresh1 # NaN => NaN/NaN 4878eac174f2Safresh1 4879e0680481Safresh1 if ($x -> is_nan()) { 4880e0680481Safresh1 return $class -> bnan() unless wantarray; 4881e0680481Safresh1 return $class -> bnan(), $class -> bnan(); 4882eac174f2Safresh1 } 4883eac174f2Safresh1 4884e0680481Safresh1 # ±Inf => ±Inf/1 4885e0680481Safresh1 4886e0680481Safresh1 if ($x -> is_inf()) { 4887e0680481Safresh1 my $numer = $class -> binf($x->{sign}); 4888e0680481Safresh1 return $numer unless wantarray; 4889e0680481Safresh1 my $denom = $class -> bone(); 4890e0680481Safresh1 return $numer, $denom; 4891eac174f2Safresh1 } 4892eac174f2Safresh1 4893e0680481Safresh1 # Finite number. 4894e0680481Safresh1 4895e0680481Safresh1 # If we get here, we know that the output is an integer. 4896e0680481Safresh1 4897e0680481Safresh1 $class = $downgrade if defined $downgrade; 4898e0680481Safresh1 4899e0680481Safresh1 my @flt_parts = ($x->{sign}, $x->{_m}, $x->{_es}, $x->{_e}); 4900e0680481Safresh1 my @rat_parts = $class -> _flt_lib_parts_to_rat_lib_parts(@flt_parts); 4901e0680481Safresh1 my $num = $class -> new($LIB -> _str($rat_parts[1])); 4902e0680481Safresh1 my $den = $class -> new($LIB -> _str($rat_parts[2])); 4903e0680481Safresh1 $num = $num -> bneg() if $rat_parts[0] eq "-"; 4904e0680481Safresh1 return $num unless wantarray; 4905e0680481Safresh1 return $num, $den; 4906eac174f2Safresh1} 4907e0680481Safresh1 4908e0680481Safresh1# Given "123.4375", returns "1975", since "123.4375" is "1975/16". 4909eac174f2Safresh1 4910eac174f2Safresh1sub numerator { 4911e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 4912eac174f2Safresh1 4913e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 4914eac174f2Safresh1 4915eac174f2Safresh1 return $class -> bnan() if $x -> is_nan(); 4916eac174f2Safresh1 return $class -> binf($x -> sign()) if $x -> is_inf(); 4917eac174f2Safresh1 return $class -> bzero() if $x -> is_zero(); 4918eac174f2Safresh1 4919e0680481Safresh1 # If we get here, we know that the output is an integer. 4920e0680481Safresh1 4921e0680481Safresh1 $class = $downgrade if defined $downgrade; 4922e0680481Safresh1 4923eac174f2Safresh1 if ($x -> {_es} eq '-') { # exponent < 0 4924eac174f2Safresh1 my $numer_lib = $LIB -> _copy($x -> {_m}); 4925eac174f2Safresh1 my $denom_lib = $LIB -> _1ex($x -> {_e}); 4926eac174f2Safresh1 my $gcd_lib = $LIB -> _gcd($LIB -> _copy($numer_lib), $denom_lib); 4927eac174f2Safresh1 $numer_lib = $LIB -> _div($numer_lib, $gcd_lib); 4928eac174f2Safresh1 return $class -> new($x -> {sign} . $LIB -> _str($numer_lib)); 4929eac174f2Safresh1 } 4930eac174f2Safresh1 4931eac174f2Safresh1 elsif (! $LIB -> _is_zero($x -> {_e})) { # exponent > 0 4932eac174f2Safresh1 my $numer_lib = $LIB -> _copy($x -> {_m}); 4933eac174f2Safresh1 $numer_lib = $LIB -> _lsft($numer_lib, $x -> {_e}, 10); 4934eac174f2Safresh1 return $class -> new($x -> {sign} . $LIB -> _str($numer_lib)); 4935eac174f2Safresh1 } 4936eac174f2Safresh1 4937eac174f2Safresh1 else { # exponent = 0 4938eac174f2Safresh1 return $class -> new($x -> {sign} . $LIB -> _str($x -> {_m})); 4939eac174f2Safresh1 } 4940eac174f2Safresh1} 4941eac174f2Safresh1 4942e0680481Safresh1# Given "123.4375", returns "16", since "123.4375" is "1975/16". 4943eac174f2Safresh1 4944e0680481Safresh1sub denominator { 4945e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 4946e0680481Safresh1 4947e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 4948eac174f2Safresh1 4949eac174f2Safresh1 return $class -> bnan() if $x -> is_nan(); 4950eac174f2Safresh1 4951e0680481Safresh1 # If we get here, we know that the output is an integer. 4952e0680481Safresh1 4953e0680481Safresh1 $class = $downgrade if defined $downgrade; 4954e0680481Safresh1 4955eac174f2Safresh1 if ($x -> {_es} eq '-') { # exponent < 0 4956eac174f2Safresh1 my $numer_lib = $LIB -> _copy($x -> {_m}); 4957eac174f2Safresh1 my $denom_lib = $LIB -> _1ex($x -> {_e}); 4958eac174f2Safresh1 my $gcd_lib = $LIB -> _gcd($LIB -> _copy($numer_lib), $denom_lib); 4959eac174f2Safresh1 $denom_lib = $LIB -> _div($denom_lib, $gcd_lib); 4960eac174f2Safresh1 return $class -> new($LIB -> _str($denom_lib)); 4961eac174f2Safresh1 } 4962eac174f2Safresh1 4963eac174f2Safresh1 else { # exponent >= 0 4964eac174f2Safresh1 return $class -> bone(); 4965eac174f2Safresh1 } 4966eac174f2Safresh1} 4967eac174f2Safresh1 49689f11ffb7Safresh1############################################################################### 49699f11ffb7Safresh1# String conversion methods 49709f11ffb7Safresh1############################################################################### 49719f11ffb7Safresh1 49729f11ffb7Safresh1sub bstr { 49739f11ffb7Safresh1 # (ref to BFLOAT or num_str) return num_str 49749f11ffb7Safresh1 # Convert number from internal format to (non-scientific) string format. 49759f11ffb7Safresh1 # internal format is always normalized (no leading zeros, "-0" => "+0") 4976e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 49779f11ffb7Safresh1 4978e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 4979e0680481Safresh1 4980e0680481Safresh1 # Inf and NaN 4981e0680481Safresh1 4982e0680481Safresh1 if ($x->{sign} ne '+' && $x->{sign} ne '-') { 49839f11ffb7Safresh1 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN 49849f11ffb7Safresh1 return 'inf'; # +inf 49859f11ffb7Safresh1 } 49869f11ffb7Safresh1 4987e0680481Safresh1 # Finite number 4988e0680481Safresh1 49899f11ffb7Safresh1 my $es = '0'; 49909f11ffb7Safresh1 my $len = 1; 49919f11ffb7Safresh1 my $cad = 0; 49929f11ffb7Safresh1 my $dot = '.'; 49939f11ffb7Safresh1 49949f11ffb7Safresh1 # $x is zero? 4995b46d8ef2Safresh1 my $not_zero = !($x->{sign} eq '+' && $LIB->_is_zero($x->{_m})); 49969f11ffb7Safresh1 if ($not_zero) { 4997b46d8ef2Safresh1 $es = $LIB->_str($x->{_m}); 49989f11ffb7Safresh1 $len = CORE::length($es); 4999b46d8ef2Safresh1 my $e = $LIB->_num($x->{_e}); 50009f11ffb7Safresh1 $e = -$e if $x->{_es} eq '-'; 50019f11ffb7Safresh1 if ($e < 0) { 50029f11ffb7Safresh1 $dot = ''; 50039f11ffb7Safresh1 # if _e is bigger than a scalar, the following will blow your memory 50049f11ffb7Safresh1 if ($e <= -$len) { 50059f11ffb7Safresh1 my $r = abs($e) - $len; 50069f11ffb7Safresh1 $es = '0.'. ('0' x $r) . $es; 50079f11ffb7Safresh1 $cad = -($len+$r); 50089f11ffb7Safresh1 } else { 50099f11ffb7Safresh1 substr($es, $e, 0) = '.'; 5010b46d8ef2Safresh1 $cad = $LIB->_num($x->{_e}); 50119f11ffb7Safresh1 $cad = -$cad if $x->{_es} eq '-'; 50129f11ffb7Safresh1 } 50139f11ffb7Safresh1 } elsif ($e > 0) { 50149f11ffb7Safresh1 # expand with zeros 50159f11ffb7Safresh1 $es .= '0' x $e; 50169f11ffb7Safresh1 $len += $e; 50179f11ffb7Safresh1 $cad = 0; 50189f11ffb7Safresh1 } 50199f11ffb7Safresh1 } # if not zero 50209f11ffb7Safresh1 50219f11ffb7Safresh1 $es = '-'.$es if $x->{sign} eq '-'; 50229f11ffb7Safresh1 # if set accuracy or precision, pad with zeros on the right side 5023*3d61058aSafresh1 if ((defined $x->{accuracy}) && ($not_zero)) { 50249f11ffb7Safresh1 # 123400 => 6, 0.1234 => 4, 0.001234 => 4 5025*3d61058aSafresh1 my $zeros = $x->{accuracy} - $cad; # cad == 0 => 12340 5026*3d61058aSafresh1 $zeros = $x->{accuracy} - $len if $cad != $len; 50279f11ffb7Safresh1 $es .= $dot.'0' x $zeros if $zeros > 0; 5028*3d61058aSafresh1 } elsif ((($x->{precision} || 0) < 0)) { 50299f11ffb7Safresh1 # 123400 => 6, 0.1234 => 4, 0.001234 => 6 5030*3d61058aSafresh1 my $zeros = -$x->{precision} + $cad; 50319f11ffb7Safresh1 $es .= $dot.'0' x $zeros if $zeros > 0; 50329f11ffb7Safresh1 } 50339f11ffb7Safresh1 $es; 50349f11ffb7Safresh1} 50359f11ffb7Safresh1 5036e0680481Safresh1# Decimal notation, e.g., "12345.6789" (no exponent). 50379f11ffb7Safresh1 50389f11ffb7Safresh1sub bdstr { 5039e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 5040e0680481Safresh1 5041e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 5042e0680481Safresh1 5043e0680481Safresh1 # Inf and NaN 50449f11ffb7Safresh1 50459f11ffb7Safresh1 if ($x->{sign} ne '+' && $x->{sign} ne '-') { 50469f11ffb7Safresh1 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN 50479f11ffb7Safresh1 return 'inf'; # +inf 50489f11ffb7Safresh1 } 50499f11ffb7Safresh1 5050e0680481Safresh1 # Upgrade? 5051e0680481Safresh1 5052e0680481Safresh1 return $upgrade -> bdstr($x, @r) 5053*3d61058aSafresh1 if defined($upgrade) && !$x -> isa(__PACKAGE__); 5054e0680481Safresh1 5055e0680481Safresh1 # Finite number 5056e0680481Safresh1 5057b46d8ef2Safresh1 my $mant = $LIB->_str($x->{_m}); 5058e0680481Safresh1 my $esgn = $x->{_es}; 5059e0680481Safresh1 my $eabs = $LIB -> _num($x->{_e}); 5060e0680481Safresh1 5061e0680481Safresh1 my $uintmax = ~0; 50629f11ffb7Safresh1 50639f11ffb7Safresh1 my $str = $mant; 5064e0680481Safresh1 if ($esgn eq '+') { 5065e0680481Safresh1 5066e0680481Safresh1 croak("The absolute value of the exponent is too large") 5067e0680481Safresh1 if $eabs > $uintmax; 5068e0680481Safresh1 5069e0680481Safresh1 $str .= "0" x $eabs; 5070e0680481Safresh1 50719f11ffb7Safresh1 } else { 5072e0680481Safresh1 my $mlen = CORE::length($mant); 5073e0680481Safresh1 my $c = $mlen - $eabs; 5074e0680481Safresh1 5075e0680481Safresh1 my $intmax = ($uintmax - 1) / 2; 5076e0680481Safresh1 croak("The absolute value of the exponent is too large") 5077e0680481Safresh1 if (1 - $c) > $intmax; 5078e0680481Safresh1 50799f11ffb7Safresh1 $str = "0" x (1 - $c) . $str if $c <= 0; 5080e0680481Safresh1 substr($str, -$eabs, 0) = '.'; 50819f11ffb7Safresh1 } 50829f11ffb7Safresh1 5083e0680481Safresh1 return $x->{sign} eq '-' ? '-' . $str : $str; 50849f11ffb7Safresh1} 50859f11ffb7Safresh1 5086e0680481Safresh1# Scientific notation with significand/mantissa and exponent as integers, e.g., 5087e0680481Safresh1# "12345.6789" is written as "123456789e-4". 50889f11ffb7Safresh1 50899f11ffb7Safresh1sub bsstr { 5090e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 5091e0680481Safresh1 5092e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 5093e0680481Safresh1 5094e0680481Safresh1 # Inf and NaN 50959f11ffb7Safresh1 50969f11ffb7Safresh1 if ($x->{sign} ne '+' && $x->{sign} ne '-') { 50979f11ffb7Safresh1 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN 50989f11ffb7Safresh1 return 'inf'; # +inf 50999f11ffb7Safresh1 } 51009f11ffb7Safresh1 5101e0680481Safresh1 # Upgrade? 5102e0680481Safresh1 5103e0680481Safresh1 return $upgrade -> bsstr($x, @r) 5104*3d61058aSafresh1 if defined($upgrade) && !$x -> isa(__PACKAGE__); 5105e0680481Safresh1 5106e0680481Safresh1 # Finite number 5107e0680481Safresh1 5108e0680481Safresh1 ($x->{sign} eq '-' ? '-' : '') . $LIB->_str($x->{_m}) 5109e0680481Safresh1 . 'e' . $x->{_es} . $LIB->_str($x->{_e}); 51109f11ffb7Safresh1} 51119f11ffb7Safresh1 51129f11ffb7Safresh1# Normalized notation, e.g., "12345.6789" is written as "1.23456789e+4". 51139f11ffb7Safresh1 51149f11ffb7Safresh1sub bnstr { 5115e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 5116e0680481Safresh1 5117e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 5118e0680481Safresh1 5119e0680481Safresh1 # Inf and NaN 51209f11ffb7Safresh1 51219f11ffb7Safresh1 if ($x->{sign} ne '+' && $x->{sign} ne '-') { 51229f11ffb7Safresh1 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN 51239f11ffb7Safresh1 return 'inf'; # +inf 51249f11ffb7Safresh1 } 51259f11ffb7Safresh1 5126e0680481Safresh1 # Upgrade? 51279f11ffb7Safresh1 5128e0680481Safresh1 return $upgrade -> bnstr($x, @r) 5129*3d61058aSafresh1 if defined($upgrade) && !$x -> isa(__PACKAGE__); 51309f11ffb7Safresh1 5131e0680481Safresh1 # Finite number 5132e0680481Safresh1 5133e0680481Safresh1 my $str = $x->{sign} eq '-' ? '-' : ''; 5134e0680481Safresh1 5135e0680481Safresh1 # Get the mantissa and the length of the mantissa. 5136e0680481Safresh1 5137e0680481Safresh1 my $mant = $LIB->_str($x->{_m}); 5138e0680481Safresh1 my $mantlen = CORE::length($mant); 5139e0680481Safresh1 5140e0680481Safresh1 if ($mantlen == 1) { 5141e0680481Safresh1 5142e0680481Safresh1 # Not decimal point when the mantissa has length one, i.e., return the 5143e0680481Safresh1 # number 2 as the string "2", not "2.". 5144e0680481Safresh1 5145e0680481Safresh1 $str .= $mant . 'e' . $x->{_es} . $LIB->_str($x->{_e}); 5146e0680481Safresh1 5147e0680481Safresh1 } else { 5148e0680481Safresh1 5149e0680481Safresh1 # Compute new exponent where the original exponent is adjusted by the 5150e0680481Safresh1 # length of the mantissa minus one (because the decimal point is after 5151e0680481Safresh1 # one digit). 5152e0680481Safresh1 5153e0680481Safresh1 my ($eabs, $esgn) = $LIB -> _sadd($LIB -> _copy($x->{_e}), $x->{_es}, 5154e0680481Safresh1 $LIB -> _new($mantlen - 1), "+"); 5155e0680481Safresh1 substr $mant, 1, 0, "."; 5156e0680481Safresh1 $str .= $mant . 'e' . $esgn . $LIB->_str($eabs); 5157e0680481Safresh1 5158e0680481Safresh1 } 5159e0680481Safresh1 5160e0680481Safresh1 return $str; 51619f11ffb7Safresh1} 51629f11ffb7Safresh1 51639f11ffb7Safresh1# Engineering notation, e.g., "12345.6789" is written as "12.3456789e+3". 51649f11ffb7Safresh1 51659f11ffb7Safresh1sub bestr { 5166e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 5167e0680481Safresh1 5168e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 5169e0680481Safresh1 5170e0680481Safresh1 # Inf and NaN 51719f11ffb7Safresh1 51729f11ffb7Safresh1 if ($x->{sign} ne '+' && $x->{sign} ne '-') { 51739f11ffb7Safresh1 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN 51749f11ffb7Safresh1 return 'inf'; # +inf 51759f11ffb7Safresh1 } 51769f11ffb7Safresh1 5177e0680481Safresh1 # Upgrade? 51789f11ffb7Safresh1 5179e0680481Safresh1 return $upgrade -> bestr($x, @r) 5180*3d61058aSafresh1 if defined($upgrade) && !$x -> isa(__PACKAGE__); 51819f11ffb7Safresh1 5182e0680481Safresh1 # Finite number 5183e0680481Safresh1 5184e0680481Safresh1 my $str = $x->{sign} eq '-' ? '-' : ''; 5185e0680481Safresh1 5186e0680481Safresh1 # Get the mantissa, the length of the mantissa, and adjust the exponent by 5187e0680481Safresh1 # the length of the mantissa minus 1 (because the dot is after one digit). 5188e0680481Safresh1 5189e0680481Safresh1 my $mant = $LIB->_str($x->{_m}); 5190e0680481Safresh1 my $mantlen = CORE::length($mant); 5191e0680481Safresh1 my ($eabs, $esgn) = $LIB -> _sadd($LIB -> _copy($x->{_e}), $x->{_es}, 5192e0680481Safresh1 $LIB -> _new($mantlen - 1), "+"); 5193e0680481Safresh1 5194e0680481Safresh1 my $dotpos = 1; 5195e0680481Safresh1 my $mod = $LIB -> _mod($LIB -> _copy($eabs), $LIB -> _new("3")); 5196e0680481Safresh1 unless ($LIB -> _is_zero($mod)) { 5197e0680481Safresh1 if ($esgn eq '+') { 5198e0680481Safresh1 $eabs = $LIB -> _sub($eabs, $mod); 5199e0680481Safresh1 $dotpos += $LIB -> _num($mod); 5200e0680481Safresh1 } else { 5201e0680481Safresh1 my $delta = $LIB -> _sub($LIB -> _new("3"), $mod); 5202e0680481Safresh1 $eabs = $LIB -> _add($eabs, $delta); 5203e0680481Safresh1 $dotpos += $LIB -> _num($delta); 5204e0680481Safresh1 } 5205e0680481Safresh1 } 5206e0680481Safresh1 5207e0680481Safresh1 if ($dotpos < $mantlen) { 5208e0680481Safresh1 substr $mant, $dotpos, 0, "."; 5209e0680481Safresh1 } elsif ($dotpos > $mantlen) { 5210e0680481Safresh1 $mant .= "0" x ($dotpos - $mantlen); 5211e0680481Safresh1 } 5212e0680481Safresh1 5213e0680481Safresh1 $str .= $mant . 'e' . $esgn . $LIB->_str($eabs); 5214e0680481Safresh1 5215e0680481Safresh1 return $str; 5216e0680481Safresh1} 5217e0680481Safresh1 5218e0680481Safresh1# Fractional notation, e.g., "123.4375" is written as "1975/16". 5219e0680481Safresh1 5220e0680481Safresh1sub bfstr { 5221e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); 5222e0680481Safresh1 5223e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 5224e0680481Safresh1 5225e0680481Safresh1 # Inf and NaN 5226e0680481Safresh1 5227e0680481Safresh1 if ($x->{sign} ne '+' && $x->{sign} ne '-') { 5228e0680481Safresh1 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN 5229e0680481Safresh1 return 'inf'; # +inf 5230e0680481Safresh1 } 5231e0680481Safresh1 5232e0680481Safresh1 # Upgrade? 5233e0680481Safresh1 5234e0680481Safresh1 return $upgrade -> bfstr($x, @r) 5235*3d61058aSafresh1 if defined($upgrade) && !$x -> isa(__PACKAGE__); 5236e0680481Safresh1 5237e0680481Safresh1 # Finite number 5238e0680481Safresh1 5239e0680481Safresh1 my $str = $x->{sign} eq '-' ? '-' : ''; 5240e0680481Safresh1 5241e0680481Safresh1 if ($x->{_es} eq '+') { 5242e0680481Safresh1 $str .= $LIB -> _str($x->{_m}) . ("0" x $LIB -> _num($x->{_e})); 5243e0680481Safresh1 } else { 5244e0680481Safresh1 my @flt_parts = ($x->{sign}, $x->{_m}, $x->{_es}, $x->{_e}); 5245e0680481Safresh1 my @rat_parts = $class -> _flt_lib_parts_to_rat_lib_parts(@flt_parts); 5246e0680481Safresh1 $str = $LIB -> _str($rat_parts[1]) . "/" . $LIB -> _str($rat_parts[2]); 5247e0680481Safresh1 $str = "-" . $str if $rat_parts[0] eq "-"; 5248e0680481Safresh1 } 5249e0680481Safresh1 5250e0680481Safresh1 return $str; 52519f11ffb7Safresh1} 52529f11ffb7Safresh1 52539f11ffb7Safresh1sub to_hex { 52549f11ffb7Safresh1 # return number as hexadecimal string (only for integers defined) 5255e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); 52569f11ffb7Safresh1 5257e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 52589f11ffb7Safresh1 5259e0680481Safresh1 # Inf and NaN 5260e0680481Safresh1 5261e0680481Safresh1 if ($x->{sign} ne '+' && $x->{sign} ne '-') { 5262e0680481Safresh1 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN 5263e0680481Safresh1 return 'inf'; # +inf 5264e0680481Safresh1 } 5265e0680481Safresh1 5266e0680481Safresh1 # Upgrade? 5267e0680481Safresh1 5268e0680481Safresh1 return $upgrade -> to_hex($x, @r) 5269*3d61058aSafresh1 if defined($upgrade) && !$x -> isa(__PACKAGE__); 5270e0680481Safresh1 5271e0680481Safresh1 # Finite number 5272e0680481Safresh1 52739f11ffb7Safresh1 return '0' if $x->is_zero(); 52749f11ffb7Safresh1 52759f11ffb7Safresh1 return $nan if $x->{_es} ne '+'; # how to do 1e-1 in hex? 52769f11ffb7Safresh1 5277b46d8ef2Safresh1 my $z = $LIB->_copy($x->{_m}); 5278b46d8ef2Safresh1 if (! $LIB->_is_zero($x->{_e})) { # > 0 5279b46d8ef2Safresh1 $z = $LIB->_lsft($z, $x->{_e}, 10); 52809f11ffb7Safresh1 } 5281b46d8ef2Safresh1 my $str = $LIB->_to_hex($z); 52829f11ffb7Safresh1 return $x->{sign} eq '-' ? "-$str" : $str; 52839f11ffb7Safresh1} 52849f11ffb7Safresh1 52859f11ffb7Safresh1sub to_oct { 52869f11ffb7Safresh1 # return number as octal digit string (only for integers defined) 5287e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); 52889f11ffb7Safresh1 5289e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 52909f11ffb7Safresh1 5291e0680481Safresh1 # Inf and NaN 5292e0680481Safresh1 5293e0680481Safresh1 if ($x->{sign} ne '+' && $x->{sign} ne '-') { 5294e0680481Safresh1 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN 5295e0680481Safresh1 return 'inf'; # +inf 5296e0680481Safresh1 } 5297e0680481Safresh1 5298e0680481Safresh1 # Upgrade? 5299e0680481Safresh1 5300*3d61058aSafresh1 return $upgrade -> to_oct($x, @r) 5301*3d61058aSafresh1 if defined($upgrade) && !$x -> isa(__PACKAGE__); 5302e0680481Safresh1 5303e0680481Safresh1 # Finite number 5304e0680481Safresh1 53059f11ffb7Safresh1 return '0' if $x->is_zero(); 53069f11ffb7Safresh1 53079f11ffb7Safresh1 return $nan if $x->{_es} ne '+'; # how to do 1e-1 in octal? 53089f11ffb7Safresh1 5309b46d8ef2Safresh1 my $z = $LIB->_copy($x->{_m}); 5310b46d8ef2Safresh1 if (! $LIB->_is_zero($x->{_e})) { # > 0 5311b46d8ef2Safresh1 $z = $LIB->_lsft($z, $x->{_e}, 10); 53129f11ffb7Safresh1 } 5313b46d8ef2Safresh1 my $str = $LIB->_to_oct($z); 53149f11ffb7Safresh1 return $x->{sign} eq '-' ? "-$str" : $str; 53159f11ffb7Safresh1} 53169f11ffb7Safresh1 53179f11ffb7Safresh1sub to_bin { 53189f11ffb7Safresh1 # return number as binary digit string (only for integers defined) 5319e0680481Safresh1 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_); 53209f11ffb7Safresh1 5321e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 53229f11ffb7Safresh1 5323e0680481Safresh1 # Inf and NaN 5324e0680481Safresh1 5325e0680481Safresh1 if ($x->{sign} ne '+' && $x->{sign} ne '-') { 5326e0680481Safresh1 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN 5327e0680481Safresh1 return 'inf'; # +inf 5328e0680481Safresh1 } 5329e0680481Safresh1 5330e0680481Safresh1 # Upgrade? 5331e0680481Safresh1 5332*3d61058aSafresh1 return $upgrade -> to_bin($x, @r) 5333*3d61058aSafresh1 if defined($upgrade) && !$x -> isa(__PACKAGE__); 5334e0680481Safresh1 5335e0680481Safresh1 # Finite number 5336e0680481Safresh1 53379f11ffb7Safresh1 return '0' if $x->is_zero(); 53389f11ffb7Safresh1 53399f11ffb7Safresh1 return $nan if $x->{_es} ne '+'; # how to do 1e-1 in binary? 53409f11ffb7Safresh1 5341b46d8ef2Safresh1 my $z = $LIB->_copy($x->{_m}); 5342b46d8ef2Safresh1 if (! $LIB->_is_zero($x->{_e})) { # > 0 5343b46d8ef2Safresh1 $z = $LIB->_lsft($z, $x->{_e}, 10); 53449f11ffb7Safresh1 } 5345b46d8ef2Safresh1 my $str = $LIB->_to_bin($z); 53469f11ffb7Safresh1 return $x->{sign} eq '-' ? "-$str" : $str; 53479f11ffb7Safresh1} 53489f11ffb7Safresh1 534956d68f1eSafresh1sub to_ieee754 { 5350e0680481Safresh1 my ($class, $x, $format, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_); 5351e0680481Safresh1 5352e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 535356d68f1eSafresh1 535456d68f1eSafresh1 my $enc; # significand encoding (applies only to decimal) 535556d68f1eSafresh1 my $k; # storage width in bits 535656d68f1eSafresh1 my $b; # base 535756d68f1eSafresh1 535856d68f1eSafresh1 if ($format =~ /^binary(\d+)\z/) { 535956d68f1eSafresh1 $k = $1; 536056d68f1eSafresh1 $b = 2; 536156d68f1eSafresh1 } elsif ($format =~ /^decimal(\d+)(dpd|bcd)?\z/) { 536256d68f1eSafresh1 $k = $1; 536356d68f1eSafresh1 $b = 10; 536456d68f1eSafresh1 $enc = $2 || 'dpd'; # default is dencely-packed decimals (DPD) 536556d68f1eSafresh1 } elsif ($format eq 'half') { 536656d68f1eSafresh1 $k = 16; 536756d68f1eSafresh1 $b = 2; 536856d68f1eSafresh1 } elsif ($format eq 'single') { 536956d68f1eSafresh1 $k = 32; 537056d68f1eSafresh1 $b = 2; 537156d68f1eSafresh1 } elsif ($format eq 'double') { 537256d68f1eSafresh1 $k = 64; 537356d68f1eSafresh1 $b = 2; 537456d68f1eSafresh1 } elsif ($format eq 'quadruple') { 537556d68f1eSafresh1 $k = 128; 537656d68f1eSafresh1 $b = 2; 537756d68f1eSafresh1 } elsif ($format eq 'octuple') { 537856d68f1eSafresh1 $k = 256; 537956d68f1eSafresh1 $b = 2; 538056d68f1eSafresh1 } elsif ($format eq 'sexdecuple') { 538156d68f1eSafresh1 $k = 512; 538256d68f1eSafresh1 $b = 2; 538356d68f1eSafresh1 } 538456d68f1eSafresh1 538556d68f1eSafresh1 if ($b == 2) { 538656d68f1eSafresh1 538756d68f1eSafresh1 # Get the parameters for this format. 538856d68f1eSafresh1 538956d68f1eSafresh1 my $p; # precision (in bits) 539056d68f1eSafresh1 my $t; # number of bits in significand 539156d68f1eSafresh1 my $w; # number of bits in exponent 539256d68f1eSafresh1 539356d68f1eSafresh1 if ($k == 16) { # binary16 (half-precision) 539456d68f1eSafresh1 $p = 11; 539556d68f1eSafresh1 $t = 10; 539656d68f1eSafresh1 $w = 5; 539756d68f1eSafresh1 } elsif ($k == 32) { # binary32 (single-precision) 539856d68f1eSafresh1 $p = 24; 539956d68f1eSafresh1 $t = 23; 540056d68f1eSafresh1 $w = 8; 540156d68f1eSafresh1 } elsif ($k == 64) { # binary64 (double-precision) 540256d68f1eSafresh1 $p = 53; 540356d68f1eSafresh1 $t = 52; 540456d68f1eSafresh1 $w = 11; 540556d68f1eSafresh1 } else { # binaryN (quadruple-precition and above) 540656d68f1eSafresh1 if ($k < 128 || $k != 32 * sprintf('%.0f', $k / 32)) { 540756d68f1eSafresh1 croak "Number of bits must be 16, 32, 64, or >= 128 and", 540856d68f1eSafresh1 " a multiple of 32"; 540956d68f1eSafresh1 } 541056d68f1eSafresh1 $p = $k - sprintf('%.0f', 4 * log($k) / log(2)) + 13; 541156d68f1eSafresh1 $t = $p - 1; 541256d68f1eSafresh1 $w = $k - $t - 1; 541356d68f1eSafresh1 } 541456d68f1eSafresh1 541556d68f1eSafresh1 # The maximum exponent, minimum exponent, and exponent bias. 541656d68f1eSafresh1 541756d68f1eSafresh1 my $emax = $class -> new(2) -> bpow($w - 1) -> bdec(); 541856d68f1eSafresh1 my $emin = 1 - $emax; 541956d68f1eSafresh1 my $bias = $emax; 542056d68f1eSafresh1 542156d68f1eSafresh1 # Get numerical sign, exponent, and mantissa/significand for bit 542256d68f1eSafresh1 # string. 542356d68f1eSafresh1 542456d68f1eSafresh1 my $sign = 0; 542556d68f1eSafresh1 my $expo; 542656d68f1eSafresh1 my $mant; 542756d68f1eSafresh1 542856d68f1eSafresh1 if ($x -> is_nan()) { # nan 542956d68f1eSafresh1 $sign = 1; 543056d68f1eSafresh1 $expo = $emax -> copy() -> binc(); 543156d68f1eSafresh1 $mant = $class -> new(2) -> bpow($t - 1); 543256d68f1eSafresh1 } elsif ($x -> is_inf()) { # inf 543356d68f1eSafresh1 $sign = 1 if $x -> is_neg(); 543456d68f1eSafresh1 $expo = $emax -> copy() -> binc(); 543556d68f1eSafresh1 $mant = $class -> bzero(); 543656d68f1eSafresh1 } elsif ($x -> is_zero()) { # zero 543756d68f1eSafresh1 $expo = $emin -> copy() -> bdec(); 543856d68f1eSafresh1 $mant = $class -> bzero(); 543956d68f1eSafresh1 } else { # normal and subnormal 544056d68f1eSafresh1 544156d68f1eSafresh1 $sign = 1 if $x -> is_neg(); 544256d68f1eSafresh1 544356d68f1eSafresh1 # Now we need to compute the mantissa and exponent in base $b. 544456d68f1eSafresh1 544556d68f1eSafresh1 my $binv = $class -> new("0.5"); 544656d68f1eSafresh1 my $b = $class -> new(2); 544756d68f1eSafresh1 my $one = $class -> bone(); 544856d68f1eSafresh1 544956d68f1eSafresh1 # We start off by initializing the exponent to zero and the 545056d68f1eSafresh1 # mantissa to the input value. Then we increase the mantissa and 545156d68f1eSafresh1 # decrease the exponent, or vice versa, until the mantissa is in 545256d68f1eSafresh1 # the desired range or we hit one of the limits for the exponent. 545356d68f1eSafresh1 545456d68f1eSafresh1 $mant = $x -> copy() -> babs(); 545556d68f1eSafresh1 545656d68f1eSafresh1 # We need to find the base 2 exponent. First make an estimate of 545756d68f1eSafresh1 # the base 2 exponent, before adjusting it below. We could skip 545856d68f1eSafresh1 # this estimation and go straight to the while-loops below, but the 545956d68f1eSafresh1 # loops are slow, especially when the final exponent is far from 546056d68f1eSafresh1 # zero and even more so if the number of digits is large. This 546156d68f1eSafresh1 # initial estimation speeds up the computation dramatically. 546256d68f1eSafresh1 # 546356d68f1eSafresh1 # log2($m * 10**$e) = log10($m + 10**$e) * log(10)/log(2) 546456d68f1eSafresh1 # = (log10($m) + $e) * log(10)/log(2) 546556d68f1eSafresh1 # = (log($m)/log(10) + $e) * log(10)/log(2) 546656d68f1eSafresh1 546756d68f1eSafresh1 my ($m, $e) = $x -> nparts(); 546856d68f1eSafresh1 my $ms = $m -> numify(); 546956d68f1eSafresh1 my $es = $e -> numify(); 547056d68f1eSafresh1 547156d68f1eSafresh1 my $expo_est = (log(abs($ms))/log(10) + $es) * log(10)/log(2); 547256d68f1eSafresh1 $expo_est = int($expo_est); 547356d68f1eSafresh1 547456d68f1eSafresh1 # Limit the exponent. 547556d68f1eSafresh1 547656d68f1eSafresh1 if ($expo_est > $emax) { 547756d68f1eSafresh1 $expo_est = $emax; 547856d68f1eSafresh1 } elsif ($expo_est < $emin) { 547956d68f1eSafresh1 $expo_est = $emin; 548056d68f1eSafresh1 } 548156d68f1eSafresh1 548256d68f1eSafresh1 # Don't multiply by a number raised to a negative exponent. This 548356d68f1eSafresh1 # will cause a division, whose result is truncated to some fixed 548456d68f1eSafresh1 # number of digits. Instead, multiply by the inverse number raised 548556d68f1eSafresh1 # to a positive exponent. 548656d68f1eSafresh1 548756d68f1eSafresh1 $expo = $class -> new($expo_est); 548856d68f1eSafresh1 if ($expo_est > 0) { 5489e0680481Safresh1 $mant = $mant -> bmul($binv -> copy() -> bpow($expo)); 549056d68f1eSafresh1 } elsif ($expo_est < 0) { 549156d68f1eSafresh1 my $expo_abs = $expo -> copy() -> bneg(); 5492e0680481Safresh1 $mant = $mant -> bmul($b -> copy() -> bpow($expo_abs)); 549356d68f1eSafresh1 } 549456d68f1eSafresh1 5495eac174f2Safresh1 # Final adjustment of the estimate above. 549656d68f1eSafresh1 549756d68f1eSafresh1 while ($mant >= $b && $expo <= $emax) { 5498e0680481Safresh1 $mant = $mant -> bmul($binv); 5499e0680481Safresh1 $expo = $expo -> binc(); 550056d68f1eSafresh1 } 550156d68f1eSafresh1 550256d68f1eSafresh1 while ($mant < $one && $expo >= $emin) { 5503e0680481Safresh1 $mant = $mant -> bmul($b); 5504e0680481Safresh1 $expo = $expo -> bdec(); 550556d68f1eSafresh1 } 550656d68f1eSafresh1 5507eac174f2Safresh1 # This is when the magnitude is larger than what can be represented 5508eac174f2Safresh1 # in this format. Encode as infinity. 550956d68f1eSafresh1 5510eac174f2Safresh1 if ($expo > $emax) { 551156d68f1eSafresh1 $mant = $class -> bzero(); 5512eac174f2Safresh1 $expo = $emax -> copy() -> binc(); 5513eac174f2Safresh1 } 5514eac174f2Safresh1 5515eac174f2Safresh1 # This is when the magnitude is so small that the number is encoded 5516eac174f2Safresh1 # as a subnormal number. 5517eac174f2Safresh1 # 5518eac174f2Safresh1 # If the magnitude is smaller than that of the smallest subnormal 5519eac174f2Safresh1 # number, and rounded downwards, it is encoded as zero. This works 5520eac174f2Safresh1 # transparently and does not need to be treated as a special case. 5521eac174f2Safresh1 # 5522eac174f2Safresh1 # If the number is between the largest subnormal number and the 5523eac174f2Safresh1 # smallest normal number, and the value is rounded upwards, the 5524eac174f2Safresh1 # value must be encoded as a normal number. This must be treated as 5525eac174f2Safresh1 # a special case. 5526eac174f2Safresh1 5527eac174f2Safresh1 elsif ($expo < $emin) { 5528eac174f2Safresh1 5529eac174f2Safresh1 # Scale up the mantissa (significand), and round to integer. 5530eac174f2Safresh1 5531eac174f2Safresh1 my $const = $class -> new($b) -> bpow($t - 1); 5532e0680481Safresh1 $mant = $mant -> bmul($const); 5533e0680481Safresh1 $mant = $mant -> bfround(0); 5534eac174f2Safresh1 5535eac174f2Safresh1 # If the mantissa overflowed, encode as the smallest normal 5536eac174f2Safresh1 # number. 5537eac174f2Safresh1 5538eac174f2Safresh1 if ($mant == $const -> bmul($b)) { 5539e0680481Safresh1 $mant = $mant -> bzero(); 5540e0680481Safresh1 $expo = $expo -> binc(); 5541eac174f2Safresh1 } 5542eac174f2Safresh1 } 5543eac174f2Safresh1 5544eac174f2Safresh1 # This is when the magnitude is within the range of what can be 5545eac174f2Safresh1 # encoded as a normal number. 5546eac174f2Safresh1 5547eac174f2Safresh1 else { 5548eac174f2Safresh1 5549eac174f2Safresh1 # Remove implicit leading bit, scale up the mantissa 5550eac174f2Safresh1 # (significand) to an integer, and round. 5551eac174f2Safresh1 5552e0680481Safresh1 $mant = $mant -> bdec(); 5553eac174f2Safresh1 my $const = $class -> new($b) -> bpow($t); 5554e0680481Safresh1 $mant = $mant -> bmul($const) -> bfround(0); 5555eac174f2Safresh1 5556eac174f2Safresh1 # If the mantissa overflowed, encode as the next larger value. 5557eac174f2Safresh1 # This works correctly also when the next larger value is 5558eac174f2Safresh1 # infinity. 5559eac174f2Safresh1 5560eac174f2Safresh1 if ($mant == $const) { 5561e0680481Safresh1 $mant = $mant -> bzero(); 5562e0680481Safresh1 $expo = $expo -> binc(); 5563eac174f2Safresh1 } 556456d68f1eSafresh1 } 556556d68f1eSafresh1 } 556656d68f1eSafresh1 5567e0680481Safresh1 $expo = $expo -> badd($bias); # add bias 556856d68f1eSafresh1 556956d68f1eSafresh1 my $signbit = "$sign"; 557056d68f1eSafresh1 557156d68f1eSafresh1 my $mantbits = $mant -> to_bin(); 557256d68f1eSafresh1 $mantbits = ("0" x ($t - CORE::length($mantbits))) . $mantbits; 557356d68f1eSafresh1 557456d68f1eSafresh1 my $expobits = $expo -> to_bin(); 557556d68f1eSafresh1 $expobits = ("0" x ($w - CORE::length($expobits))) . $expobits; 557656d68f1eSafresh1 557756d68f1eSafresh1 my $bin = $signbit . $expobits . $mantbits; 557856d68f1eSafresh1 return pack "B*", $bin; 557956d68f1eSafresh1 } 558056d68f1eSafresh1 558156d68f1eSafresh1 croak("The format '$format' is not yet supported."); 558256d68f1eSafresh1} 558356d68f1eSafresh1 55849f11ffb7Safresh1sub as_hex { 55859f11ffb7Safresh1 # return number as hexadecimal string (only for integers defined) 55869f11ffb7Safresh1 5587e0680481Safresh1 my (undef, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); 5588e0680481Safresh1 5589e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 55909f11ffb7Safresh1 55919f11ffb7Safresh1 return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc 55929f11ffb7Safresh1 return '0x0' if $x->is_zero(); 55939f11ffb7Safresh1 55949f11ffb7Safresh1 return $nan if $x->{_es} ne '+'; # how to do 1e-1 in hex? 55959f11ffb7Safresh1 5596b46d8ef2Safresh1 my $z = $LIB->_copy($x->{_m}); 5597b46d8ef2Safresh1 if (! $LIB->_is_zero($x->{_e})) { # > 0 5598b46d8ef2Safresh1 $z = $LIB->_lsft($z, $x->{_e}, 10); 55999f11ffb7Safresh1 } 5600b46d8ef2Safresh1 my $str = $LIB->_as_hex($z); 56019f11ffb7Safresh1 return $x->{sign} eq '-' ? "-$str" : $str; 56029f11ffb7Safresh1} 56039f11ffb7Safresh1 56049f11ffb7Safresh1sub as_oct { 56059f11ffb7Safresh1 # return number as octal digit string (only for integers defined) 56069f11ffb7Safresh1 5607e0680481Safresh1 my (undef, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); 5608e0680481Safresh1 5609e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 56109f11ffb7Safresh1 56119f11ffb7Safresh1 return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc 56129f11ffb7Safresh1 return '00' if $x->is_zero(); 56139f11ffb7Safresh1 56149f11ffb7Safresh1 return $nan if $x->{_es} ne '+'; # how to do 1e-1 in octal? 56159f11ffb7Safresh1 5616b46d8ef2Safresh1 my $z = $LIB->_copy($x->{_m}); 5617b46d8ef2Safresh1 if (! $LIB->_is_zero($x->{_e})) { # > 0 5618b46d8ef2Safresh1 $z = $LIB->_lsft($z, $x->{_e}, 10); 56199f11ffb7Safresh1 } 5620b46d8ef2Safresh1 my $str = $LIB->_as_oct($z); 56219f11ffb7Safresh1 return $x->{sign} eq '-' ? "-$str" : $str; 56229f11ffb7Safresh1} 56239f11ffb7Safresh1 56249f11ffb7Safresh1sub as_bin { 56259f11ffb7Safresh1 # return number as binary digit string (only for integers defined) 56269f11ffb7Safresh1 5627e0680481Safresh1 my (undef, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); 5628e0680481Safresh1 5629e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 56309f11ffb7Safresh1 56319f11ffb7Safresh1 return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc 56329f11ffb7Safresh1 return '0b0' if $x->is_zero(); 56339f11ffb7Safresh1 56349f11ffb7Safresh1 return $nan if $x->{_es} ne '+'; # how to do 1e-1 in binary? 56359f11ffb7Safresh1 5636b46d8ef2Safresh1 my $z = $LIB->_copy($x->{_m}); 5637b46d8ef2Safresh1 if (! $LIB->_is_zero($x->{_e})) { # > 0 5638b46d8ef2Safresh1 $z = $LIB->_lsft($z, $x->{_e}, 10); 56399f11ffb7Safresh1 } 5640b46d8ef2Safresh1 my $str = $LIB->_as_bin($z); 56419f11ffb7Safresh1 return $x->{sign} eq '-' ? "-$str" : $str; 56429f11ffb7Safresh1} 56439f11ffb7Safresh1 56449f11ffb7Safresh1sub numify { 56459f11ffb7Safresh1 # Make a Perl scalar number from a Math::BigFloat object. 5646e0680481Safresh1 5647e0680481Safresh1 my (undef, $x, @r) = ref($_[0]) ? (undef, @_) : objectify(1, @_); 5648e0680481Safresh1 5649e0680481Safresh1 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r; 56509f11ffb7Safresh1 56519f11ffb7Safresh1 if ($x -> is_nan()) { 56529f11ffb7Safresh1 require Math::Complex; 5653eac174f2Safresh1 my $inf = $Math::Complex::Inf; 56549f11ffb7Safresh1 return $inf - $inf; 56559f11ffb7Safresh1 } 56569f11ffb7Safresh1 56579f11ffb7Safresh1 if ($x -> is_inf()) { 56589f11ffb7Safresh1 require Math::Complex; 5659eac174f2Safresh1 my $inf = $Math::Complex::Inf; 56609f11ffb7Safresh1 return $x -> is_negative() ? -$inf : $inf; 56619f11ffb7Safresh1 } 56629f11ffb7Safresh1 56639f11ffb7Safresh1 # Create a string and let Perl's atoi()/atof() handle the rest. 5664e0680481Safresh1 566556d68f1eSafresh1 return 0 + $x -> bnstr(); 56669f11ffb7Safresh1} 56679f11ffb7Safresh1 56689f11ffb7Safresh1############################################################################### 56699f11ffb7Safresh1# Private methods and functions. 56709f11ffb7Safresh1############################################################################### 56719f11ffb7Safresh1 56729f11ffb7Safresh1sub import { 56739f11ffb7Safresh1 my $class = shift; 5674eac174f2Safresh1 $IMPORT++; # remember we did import() 5675eac174f2Safresh1 my @a; # unrecognized arguments 5676eac174f2Safresh1 5677*3d61058aSafresh1 my @import = (); 5678*3d61058aSafresh1 5679eac174f2Safresh1 while (@_) { 5680eac174f2Safresh1 my $param = shift; 5681eac174f2Safresh1 5682eac174f2Safresh1 # Enable overloading of constants. 5683eac174f2Safresh1 5684eac174f2Safresh1 if ($param eq ':constant') { 5685eac174f2Safresh1 overload::constant 5686eac174f2Safresh1 5687eac174f2Safresh1 integer => sub { 5688eac174f2Safresh1 $class -> new(shift); 5689eac174f2Safresh1 }, 5690eac174f2Safresh1 5691eac174f2Safresh1 float => sub { 5692eac174f2Safresh1 $class -> new(shift); 5693eac174f2Safresh1 }, 5694eac174f2Safresh1 5695eac174f2Safresh1 binary => sub { 5696eac174f2Safresh1 # E.g., a literal 0377 shall result in an object whose value 5697eac174f2Safresh1 # is decimal 255, but new("0377") returns decimal 377. 5698eac174f2Safresh1 return $class -> from_oct($_[0]) if $_[0] =~ /^0_*[0-7]/; 5699eac174f2Safresh1 $class -> new(shift); 5700eac174f2Safresh1 }; 5701eac174f2Safresh1 next; 5702eac174f2Safresh1 } 5703eac174f2Safresh1 5704eac174f2Safresh1 # Upgrading. 5705eac174f2Safresh1 5706eac174f2Safresh1 if ($param eq 'upgrade') { 5707eac174f2Safresh1 $class -> upgrade(shift); 5708eac174f2Safresh1 next; 5709eac174f2Safresh1 } 5710eac174f2Safresh1 5711eac174f2Safresh1 # Downgrading. 5712eac174f2Safresh1 5713eac174f2Safresh1 if ($param eq 'downgrade') { 5714eac174f2Safresh1 $class -> downgrade(shift); 5715eac174f2Safresh1 next; 5716eac174f2Safresh1 } 5717eac174f2Safresh1 5718eac174f2Safresh1 # Accuracy. 5719eac174f2Safresh1 5720eac174f2Safresh1 if ($param eq 'accuracy') { 5721eac174f2Safresh1 $class -> accuracy(shift); 5722eac174f2Safresh1 next; 5723eac174f2Safresh1 } 5724eac174f2Safresh1 5725eac174f2Safresh1 # Precision. 5726eac174f2Safresh1 5727eac174f2Safresh1 if ($param eq 'precision') { 5728eac174f2Safresh1 $class -> precision(shift); 5729eac174f2Safresh1 next; 5730eac174f2Safresh1 } 5731eac174f2Safresh1 5732eac174f2Safresh1 # Rounding mode. 5733eac174f2Safresh1 5734eac174f2Safresh1 if ($param eq 'round_mode') { 5735eac174f2Safresh1 $class -> round_mode(shift); 5736eac174f2Safresh1 next; 5737eac174f2Safresh1 } 5738eac174f2Safresh1 5739*3d61058aSafresh1 # Fall-back accuracy. 5740*3d61058aSafresh1 5741*3d61058aSafresh1 if ($param eq 'div_scale') { 5742*3d61058aSafresh1 $class -> div_scale(shift); 5743*3d61058aSafresh1 next; 5744*3d61058aSafresh1 } 5745*3d61058aSafresh1 5746eac174f2Safresh1 # Backend library. 5747eac174f2Safresh1 5748eac174f2Safresh1 if ($param =~ /^(lib|try|only)\z/) { 5749eac174f2Safresh1 push @import, $param; 5750eac174f2Safresh1 push @import, shift() if @_; 5751eac174f2Safresh1 next; 5752eac174f2Safresh1 } 5753eac174f2Safresh1 5754eac174f2Safresh1 if ($param eq 'with') { 57559f11ffb7Safresh1 # alternative class for our private parts() 57569f11ffb7Safresh1 # XXX: no longer supported 5757eac174f2Safresh1 # $LIB = shift() || 'Calc'; 5758eac174f2Safresh1 # carp "'with' is no longer supported, use 'lib', 'try', or 'only'"; 5759eac174f2Safresh1 shift; 5760eac174f2Safresh1 next; 57619f11ffb7Safresh1 } 57629f11ffb7Safresh1 5763eac174f2Safresh1 # Unrecognized parameter. 57649f11ffb7Safresh1 5765eac174f2Safresh1 push @a, $param; 5766eac174f2Safresh1 } 57679f11ffb7Safresh1 5768eac174f2Safresh1 Math::BigInt -> import(@import); 5769eac174f2Safresh1 5770*3d61058aSafresh1 # find out which library was actually loaded 5771b46d8ef2Safresh1 $LIB = Math::BigInt -> config('lib'); 57729f11ffb7Safresh1 5773*3d61058aSafresh1 $class -> SUPER::import(@a); # for subclasses 5774*3d61058aSafresh1 $class -> export_to_level(1, $class, @a) if @a; # need this, too 57759f11ffb7Safresh1} 57769f11ffb7Safresh1 57779f11ffb7Safresh1sub _len_to_steps { 57789f11ffb7Safresh1 # Given D (digits in decimal), compute N so that N! (N factorial) is 57799f11ffb7Safresh1 # at least D digits long. D should be at least 50. 57809f11ffb7Safresh1 my $d = shift; 57819f11ffb7Safresh1 57829f11ffb7Safresh1 # two constants for the Ramanujan estimate of ln(N!) 57839f11ffb7Safresh1 my $lg2 = log(2 * 3.14159265) / 2; 57849f11ffb7Safresh1 my $lg10 = log(10); 57859f11ffb7Safresh1 57869f11ffb7Safresh1 # D = 50 => N => 42, so L = 40 and R = 50 57879f11ffb7Safresh1 my $l = 40; 57889f11ffb7Safresh1 my $r = $d; 57899f11ffb7Safresh1 5790e0680481Safresh1 # Otherwise this does not work under -Mbignum and we do not yet have "no 5791e0680481Safresh1 # bignum;" :( 57929f11ffb7Safresh1 $l = $l->numify if ref($l); 57939f11ffb7Safresh1 $r = $r->numify if ref($r); 57949f11ffb7Safresh1 $lg2 = $lg2->numify if ref($lg2); 57959f11ffb7Safresh1 $lg10 = $lg10->numify if ref($lg10); 57969f11ffb7Safresh1 5797e0680481Safresh1 # binary search for the right value (could this be written as the reverse of 5798e0680481Safresh1 # lg(n!)?) 57999f11ffb7Safresh1 while ($r - $l > 1) { 58009f11ffb7Safresh1 my $n = int(($r - $l) / 2) + $l; 5801e0680481Safresh1 my $ramanujan 5802e0680481Safresh1 = int(($n * log($n) - $n + log($n * (1 + 4*$n*(1+2*$n))) / 6 + $lg2) 5803e0680481Safresh1 / $lg10); 58049f11ffb7Safresh1 $ramanujan > $d ? $r = $n : $l = $n; 58059f11ffb7Safresh1 } 58069f11ffb7Safresh1 $l; 58079f11ffb7Safresh1} 58089f11ffb7Safresh1 58099f11ffb7Safresh1sub _log { 5810b8851fccSafresh1 # internal log function to calculate ln() based on Taylor series. 5811b8851fccSafresh1 # Modifies $x in place. 5812b46d8ef2Safresh1 my ($x, $scale) = @_; 5813b46d8ef2Safresh1 my $class = ref $x; 5814b8851fccSafresh1 5815b8851fccSafresh1 # in case of $x == 1, result is 0 5816b8851fccSafresh1 return $x -> bzero() if $x -> is_one(); 5817b8851fccSafresh1 5818b8851fccSafresh1 # XXX TODO: rewrite this in a similar manner to bexp() 5819b8851fccSafresh1 5820b8851fccSafresh1 # http://www.efunda.com/math/taylor_series/logarithmic.cfm?search_string=log 5821b8851fccSafresh1 5822b8851fccSafresh1 # u = x-1, v = x+1 5823b8851fccSafresh1 # _ _ 5824b8851fccSafresh1 # Taylor: | u 1 u^3 1 u^5 | 5825b8851fccSafresh1 # ln (x) = 2 | --- + - * --- + - * --- + ... | x > 0 5826b8851fccSafresh1 # |_ v 3 v^3 5 v^5 _| 5827b8851fccSafresh1 5828b8851fccSafresh1 # This takes much more steps to calculate the result and is thus not used 5829b8851fccSafresh1 # u = x-1 5830b8851fccSafresh1 # _ _ 5831b8851fccSafresh1 # Taylor: | u 1 u^2 1 u^3 | 5832b8851fccSafresh1 # ln (x) = 2 | --- + - * --- + - * --- + ... | x > 1/2 5833b8851fccSafresh1 # |_ x 2 x^2 3 x^3 _| 5834b8851fccSafresh1 5835*3d61058aSafresh1 # scale used in intermediate computations 5836*3d61058aSafresh1 my $scaleup = $scale + 4; 5837*3d61058aSafresh1 5838*3d61058aSafresh1 my ($v, $u, $numer, $denom, $factor, $f); 5839b8851fccSafresh1 5840e0680481Safresh1 $v = $x -> copy(); 5841e0680481Safresh1 $v = $v -> binc(); # v = x+1 5842e0680481Safresh1 $x = $x -> bdec(); 5843e0680481Safresh1 $u = $x -> copy(); # u = x-1; x = x-1 5844*3d61058aSafresh1 5845*3d61058aSafresh1 $x = $x -> bdiv($v, $scaleup); # first term: u/v 5846*3d61058aSafresh1 5847*3d61058aSafresh1 $numer = $u -> copy(); # numerator 5848*3d61058aSafresh1 $denom = $v -> copy(); # denominator 5849*3d61058aSafresh1 5850e0680481Safresh1 $u = $u -> bmul($u); # u^2 5851e0680481Safresh1 $v = $v -> bmul($v); # v^2 5852*3d61058aSafresh1 5853*3d61058aSafresh1 $numer = $numer -> bmul($u); # u^3 5854*3d61058aSafresh1 $denom = $denom -> bmul($v); # v^3 5855*3d61058aSafresh1 5856e0680481Safresh1 $factor = $class -> new(3); 5857e0680481Safresh1 $f = $class -> new(2); 5858b8851fccSafresh1 5859*3d61058aSafresh1 while (1) { 5860*3d61058aSafresh1 my $next = $numer -> copy() -> bround($scaleup) 5861*3d61058aSafresh1 -> bdiv($denom -> copy() -> bmul($factor) -> bround($scaleup), $scaleup); 5862b46d8ef2Safresh1 5863*3d61058aSafresh1 $next->{accuracy} = undef; 5864*3d61058aSafresh1 $next->{precision} = undef; 5865*3d61058aSafresh1 my $x_prev = $x -> copy(); 5866e0680481Safresh1 $x = $x -> badd($next); 5867*3d61058aSafresh1 5868*3d61058aSafresh1 last if $x -> bacmp($x_prev) == 0; 5869*3d61058aSafresh1 5870b8851fccSafresh1 # calculate things for the next term 5871*3d61058aSafresh1 $numer = $numer -> bmul($u); 5872*3d61058aSafresh1 $denom = $denom -> bmul($v); 5873e0680481Safresh1 $factor = $factor -> badd($f); 5874b8851fccSafresh1 } 5875*3d61058aSafresh1 5876*3d61058aSafresh1 $x = $x -> bmul($f); # $x *= 2 5877*3d61058aSafresh1 $x = $x -> bround($scale); 5878b8851fccSafresh1} 5879b8851fccSafresh1 58809f11ffb7Safresh1sub _log_10 { 5881b8851fccSafresh1 # Internal log function based on reducing input to the range of 0.1 .. 9.99 5882b8851fccSafresh1 # and then "correcting" the result to the proper one. Modifies $x in place. 5883b46d8ef2Safresh1 my ($x, $scale) = @_; 5884b46d8ef2Safresh1 my $class = ref $x; 5885b8851fccSafresh1 5886b8851fccSafresh1 # Taking blog() from numbers greater than 10 takes a *very long* time, so we 5887b8851fccSafresh1 # break the computation down into parts based on the observation that: 5888b8851fccSafresh1 # blog(X*Y) = blog(X) + blog(Y) 5889b8851fccSafresh1 # We set Y here to multiples of 10 so that $x becomes below 1 - the smaller 5890b8851fccSafresh1 # $x is the faster it gets. Since 2*$x takes about 10 times as 5891b8851fccSafresh1 # long, we make it faster by about a factor of 100 by dividing $x by 10. 5892b8851fccSafresh1 5893b8851fccSafresh1 # The same observation is valid for numbers smaller than 0.1, e.g. computing 5894e0680481Safresh1 # log(1) is fastest, and the further away we get from 1, the longer it 5895e0680481Safresh1 # takes. So we also 'break' this down by multiplying $x with 10 and subtract 5896e0680481Safresh1 # the log(10) afterwards to get the correct result. 5897b8851fccSafresh1 5898b8851fccSafresh1 # To get $x even closer to 1, we also divide by 2 and then use log(2) to 5899b8851fccSafresh1 # correct for this. For instance if $x is 2.4, we use the formula: 5900b8851fccSafresh1 # blog(2.4 * 2) == blog(1.2) + blog(2) 5901b8851fccSafresh1 # and thus calculate only blog(1.2) and blog(2), which is faster in total 5902b8851fccSafresh1 # than calculating blog(2.4). 5903b8851fccSafresh1 5904b8851fccSafresh1 # In addition, the values for blog(2) and blog(10) are cached. 5905b8851fccSafresh1 5906*3d61058aSafresh1 # Calculate the number of digits before the dot, i.e., 1 + floor(log10(x)): 5907*3d61058aSafresh1 # x = 123 => dbd = 3 5908*3d61058aSafresh1 # x = 1.23 => dbd = 1 5909*3d61058aSafresh1 # x = 0.0123 => dbd = -1 5910*3d61058aSafresh1 # x = 0.000123 => dbd = -3 5911*3d61058aSafresh1 # etc. 5912b46d8ef2Safresh1 5913b46d8ef2Safresh1 my $dbd = $LIB->_num($x->{_e}); 5914b8851fccSafresh1 $dbd = -$dbd if $x->{_es} eq '-'; 5915b46d8ef2Safresh1 $dbd += $LIB->_len($x->{_m}); 5916b8851fccSafresh1 5917b8851fccSafresh1 # more than one digit (e.g. at least 10), but *not* exactly 10 to avoid 5918b8851fccSafresh1 # infinite recursion 5919b8851fccSafresh1 5920b8851fccSafresh1 my $calc = 1; # do some calculation? 5921b8851fccSafresh1 5922*3d61058aSafresh1 # No upgrading or downgrading in the intermediate computations. 5923*3d61058aSafresh1 5924*3d61058aSafresh1 my $upg = $class -> upgrade(); 5925*3d61058aSafresh1 my $dng = $class -> downgrade(); 5926*3d61058aSafresh1 $class -> upgrade(undef); 5927*3d61058aSafresh1 $class -> downgrade(undef); 5928*3d61058aSafresh1 5929b8851fccSafresh1 # disable the shortcut for 10, since we need log(10) and this would recurse 5930b8851fccSafresh1 # infinitely deep 5931b46d8ef2Safresh1 if ($x->{_es} eq '+' && # $x == 10 5932b46d8ef2Safresh1 ($LIB->_is_one($x->{_e}) && 5933b46d8ef2Safresh1 $LIB->_is_one($x->{_m}))) 5934b46d8ef2Safresh1 { 5935b8851fccSafresh1 $dbd = 0; # disable shortcut 5936b8851fccSafresh1 # we can use the cached value in these cases 59379f11ffb7Safresh1 if ($scale <= $LOG_10_A) { 5938e0680481Safresh1 $x = $x->bzero(); 5939e0680481Safresh1 $x = $x->badd($LOG_10); # modify $x in place 5940b8851fccSafresh1 $calc = 0; # no need to calc, but round 5941b8851fccSafresh1 } 5942b8851fccSafresh1 # if we can't use the shortcut, we continue normally 59439f11ffb7Safresh1 } else { 5944b8851fccSafresh1 # disable the shortcut for 2, since we maybe have it cached 5945b46d8ef2Safresh1 if (($LIB->_is_zero($x->{_e}) && # $x == 2 5946b46d8ef2Safresh1 $LIB->_is_two($x->{_m}))) 5947b46d8ef2Safresh1 { 5948b8851fccSafresh1 $dbd = 0; # disable shortcut 5949b8851fccSafresh1 # we can use the cached value in these cases 59509f11ffb7Safresh1 if ($scale <= $LOG_2_A) { 5951e0680481Safresh1 $x = $x->bzero(); 5952e0680481Safresh1 $x = $x->badd($LOG_2); # modify $x in place 5953b8851fccSafresh1 $calc = 0; # no need to calc, but round 5954b8851fccSafresh1 } 5955b8851fccSafresh1 # if we can't use the shortcut, we continue normally 5956b8851fccSafresh1 } 5957b8851fccSafresh1 } 5958b8851fccSafresh1 5959b8851fccSafresh1 # if $x = 0.1, we know the result must be 0-log(10) 5960b46d8ef2Safresh1 if ($calc != 0 && 5961b46d8ef2Safresh1 ($x->{_es} eq '-' && # $x == 0.1 5962b46d8ef2Safresh1 ($LIB->_is_one($x->{_e}) && 5963b46d8ef2Safresh1 $LIB->_is_one($x->{_m})))) 5964b46d8ef2Safresh1 { 5965b8851fccSafresh1 $dbd = 0; # disable shortcut 5966b8851fccSafresh1 # we can use the cached value in these cases 59679f11ffb7Safresh1 if ($scale <= $LOG_10_A) { 5968e0680481Safresh1 $x = $x->bzero(); 5969e0680481Safresh1 $x = $x->bsub($LOG_10); 5970b8851fccSafresh1 $calc = 0; # no need to calc, but round 5971b8851fccSafresh1 } 5972b8851fccSafresh1 } 5973b8851fccSafresh1 5974b46d8ef2Safresh1 return $x if $calc == 0; # already have the result 5975b8851fccSafresh1 5976b8851fccSafresh1 # default: these correction factors are undef and thus not used 5977b8851fccSafresh1 my $l_10; # value of ln(10) to A of $scale 5978b8851fccSafresh1 my $l_2; # value of ln(2) to A of $scale 5979b8851fccSafresh1 59809f11ffb7Safresh1 my $two = $class->new(2); 5981b8851fccSafresh1 5982b8851fccSafresh1 # $x == 2 => 1, $x == 13 => 2, $x == 0.1 => 0, $x == 0.01 => -1 5983b8851fccSafresh1 # so don't do this shortcut for 1 or 0 59849f11ffb7Safresh1 if (($dbd > 1) || ($dbd < 0)) { 5985b8851fccSafresh1 # convert our cached value to an object if not already (avoid doing this 5986b8851fccSafresh1 # at import() time, since not everybody needs this) 59879f11ffb7Safresh1 $LOG_10 = $class->new($LOG_10, undef, undef) unless ref $LOG_10; 5988b8851fccSafresh1 5989e0680481Safresh1 # got more than one digit before the dot, or more than one zero after 5990e0680481Safresh1 # the dot, so do: 5991b8851fccSafresh1 # log(123) == log(1.23) + log(10) * 2 5992b8851fccSafresh1 # log(0.0123) == log(1.23) - log(10) * 2 5993b8851fccSafresh1 59949f11ffb7Safresh1 if ($scale <= $LOG_10_A) { 5995b8851fccSafresh1 # use cached value 5996b8851fccSafresh1 $l_10 = $LOG_10->copy(); # copy for mul 59979f11ffb7Safresh1 } else { 5998b8851fccSafresh1 # else: slower, compute and cache result 5999e0680481Safresh1 6000b8851fccSafresh1 # shorten the time to calculate log(10) based on the following: 6001b8851fccSafresh1 # log(1.25 * 8) = log(1.25) + log(8) 6002b8851fccSafresh1 # = log(1.25) + log(2) + log(2) + log(2) 6003b8851fccSafresh1 6004b8851fccSafresh1 # first get $l_2 (and possible compute and cache log(2)) 60059f11ffb7Safresh1 $LOG_2 = $class->new($LOG_2, undef, undef) unless ref $LOG_2; 60069f11ffb7Safresh1 if ($scale <= $LOG_2_A) { 6007b8851fccSafresh1 # use cached value 6008b8851fccSafresh1 $l_2 = $LOG_2->copy(); # copy() for the mul below 60099f11ffb7Safresh1 } else { 6010b8851fccSafresh1 # else: slower, compute and cache result 60119f11ffb7Safresh1 $l_2 = $two->copy(); 6012e0680481Safresh1 $l_2 = $l_2->_log($scale); # scale+4, actually 6013b8851fccSafresh1 $LOG_2 = $l_2->copy(); # cache the result for later 6014b8851fccSafresh1 # the copy() is for mul below 6015b8851fccSafresh1 $LOG_2_A = $scale; 6016b8851fccSafresh1 } 6017b8851fccSafresh1 6018b8851fccSafresh1 # now calculate log(1.25): 60199f11ffb7Safresh1 $l_10 = $class->new('1.25'); 6020e0680481Safresh1 $l_10 = $l_10->_log($scale); # scale+4, actually 6021b8851fccSafresh1 6022b8851fccSafresh1 # log(1.25) + log(2) + log(2) + log(2): 6023e0680481Safresh1 $l_10 = $l_10->badd($l_2); 6024e0680481Safresh1 $l_10 = $l_10->badd($l_2); 6025e0680481Safresh1 $l_10 = $l_10->badd($l_2); 6026b8851fccSafresh1 $LOG_10 = $l_10->copy(); # cache the result for later 6027b8851fccSafresh1 # the copy() is for mul below 6028b8851fccSafresh1 $LOG_10_A = $scale; 6029b8851fccSafresh1 } 6030b8851fccSafresh1 $dbd-- if ($dbd > 1); # 20 => dbd=2, so make it dbd=1 6031e0680481Safresh1 $l_10 = $l_10->bmul($class->new($dbd)); # log(10) * (digits_before_dot-1) 6032b8851fccSafresh1 my $dbd_sign = '+'; 60339f11ffb7Safresh1 if ($dbd < 0) { 6034b8851fccSafresh1 $dbd = -$dbd; 6035b8851fccSafresh1 $dbd_sign = '-'; 6036b8851fccSafresh1 } 6037b8851fccSafresh1 ($x->{_e}, $x->{_es}) = 6038e0680481Safresh1 $LIB -> _ssub($x->{_e}, $x->{_es}, $LIB->_new($dbd), $dbd_sign); 6039b8851fccSafresh1 } 6040b8851fccSafresh1 6041b8851fccSafresh1 # Now: 0.1 <= $x < 10 (and possible correction in l_10) 6042b8851fccSafresh1 6043b8851fccSafresh1 ### Since $x in the range 0.5 .. 1.5 is MUCH faster, we do a repeated div 6044b8851fccSafresh1 ### or mul by 2 (maximum times 3, since x < 10 and x > 0.1) 6045b8851fccSafresh1 60469f11ffb7Safresh1 $HALF = $class->new($HALF) unless ref($HALF); 6047b8851fccSafresh1 6048b8851fccSafresh1 my $twos = 0; # default: none (0 times) 60499f11ffb7Safresh1 while ($x->bacmp($HALF) <= 0) { # X <= 0.5 60509f11ffb7Safresh1 $twos--; 6051e0680481Safresh1 $x = $x->bmul($two); 6052b8851fccSafresh1 } 60539f11ffb7Safresh1 while ($x->bacmp($two) >= 0) { # X >= 2 60549f11ffb7Safresh1 $twos++; 6055e0680481Safresh1 $x = $x->bdiv($two, $scale+4); # keep all digits 6056b8851fccSafresh1 } 6057e0680481Safresh1 $x = $x->bround($scale+4); 6058b8851fccSafresh1 # $twos > 0 => did mul 2, < 0 => did div 2 (but we never did both) 6059b8851fccSafresh1 # So calculate correction factor based on ln(2): 60609f11ffb7Safresh1 if ($twos != 0) { 60619f11ffb7Safresh1 $LOG_2 = $class->new($LOG_2, undef, undef) unless ref $LOG_2; 60629f11ffb7Safresh1 if ($scale <= $LOG_2_A) { 6063b8851fccSafresh1 # use cached value 6064b8851fccSafresh1 $l_2 = $LOG_2->copy(); # copy() for the mul below 60659f11ffb7Safresh1 } else { 6066b8851fccSafresh1 # else: slower, compute and cache result 60679f11ffb7Safresh1 $l_2 = $two->copy(); 6068e0680481Safresh1 $l_2 = $l_2->_log($scale); # scale+4, actually 6069b8851fccSafresh1 $LOG_2 = $l_2->copy(); # cache the result for later 6070b8851fccSafresh1 # the copy() is for mul below 6071b8851fccSafresh1 $LOG_2_A = $scale; 6072b8851fccSafresh1 } 6073e0680481Safresh1 $l_2 = $l_2->bmul($twos); # * -2 => subtract, * 2 => add 60749f11ffb7Safresh1 } else { 6075b8851fccSafresh1 undef $l_2; 6076b8851fccSafresh1 } 6077b8851fccSafresh1 6078e0680481Safresh1 $x = $x->_log($scale); # need to do the "normal" way 6079e0680481Safresh1 $x = $x->badd($l_10) if defined $l_10; # correct it by ln(10) 6080e0680481Safresh1 $x = $x->badd($l_2) if defined $l_2; # and maybe by ln(2) 6081b8851fccSafresh1 6082*3d61058aSafresh1 # Restore globals 6083*3d61058aSafresh1 6084*3d61058aSafresh1 $class -> upgrade($upg); 6085*3d61058aSafresh1 $class -> downgrade($dng); 6086*3d61058aSafresh1 6087b8851fccSafresh1 # all done, $x contains now the result 6088b8851fccSafresh1 $x; 6089b8851fccSafresh1} 6090b8851fccSafresh1 60919f11ffb7Safresh1sub _pow { 6092b8851fccSafresh1 # Calculate a power where $y is a non-integer, like 2 ** 0.3 6093b8851fccSafresh1 my ($x, $y, @r) = @_; 60949f11ffb7Safresh1 my $class = ref($x); 6095b8851fccSafresh1 6096b8851fccSafresh1 # if $y == 0.5, it is sqrt($x) 60979f11ffb7Safresh1 $HALF = $class->new($HALF) unless ref($HALF); 6098b8851fccSafresh1 return $x->bsqrt(@r, $y) if $y->bcmp($HALF) == 0; 6099b8851fccSafresh1 6100b8851fccSafresh1 # Using: 6101b8851fccSafresh1 # a ** x == e ** (x * ln a) 6102b8851fccSafresh1 6103b8851fccSafresh1 # u = y * ln x 6104b8851fccSafresh1 # _ _ 6105b8851fccSafresh1 # Taylor: | u u^2 u^3 | 6106b8851fccSafresh1 # x ** y = 1 + | --- + --- + ----- + ... | 6107b8851fccSafresh1 # |_ 1 1*2 1*2*3 _| 6108b8851fccSafresh1 6109b8851fccSafresh1 # we need to limit the accuracy to protect against overflow 6110b8851fccSafresh1 my $fallback = 0; 6111b8851fccSafresh1 my ($scale, @params); 6112b8851fccSafresh1 ($x, @params) = $x->_find_round_parameters(@r); 6113b8851fccSafresh1 6114b8851fccSafresh1 return $x if $x->is_nan(); # error in _find_round_parameters? 6115b8851fccSafresh1 6116b8851fccSafresh1 # no rounding at all, so must use fallback 6117b8851fccSafresh1 if (scalar @params == 0) { 6118b8851fccSafresh1 # simulate old behaviour 6119b8851fccSafresh1 $params[0] = $class->div_scale(); # and round to it as accuracy 6120b8851fccSafresh1 $params[1] = undef; # disable P 6121b8851fccSafresh1 $scale = $params[0]+4; # at least four more for proper round 6122b8851fccSafresh1 $params[2] = $r[2]; # round mode by caller or undef 6123b8851fccSafresh1 $fallback = 1; # to clear a/p afterwards 6124b8851fccSafresh1 } else { 6125b8851fccSafresh1 # the 4 below is empirical, and there might be cases where it is not 6126b8851fccSafresh1 # enough... 6127b8851fccSafresh1 $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined 6128b8851fccSafresh1 } 6129b8851fccSafresh1 6130*3d61058aSafresh1 # When user set globals, they would interfere with our calculation, so 6131*3d61058aSafresh1 # disable them and later re-enable them. 6132*3d61058aSafresh1 6133*3d61058aSafresh1 my $ab = $class -> accuracy(); 6134*3d61058aSafresh1 my $pb = $class -> precision(); 6135*3d61058aSafresh1 $class -> accuracy(undef); 6136*3d61058aSafresh1 $class -> precision(undef); 6137e0680481Safresh1 6138e0680481Safresh1 # Disabling upgrading and downgrading is no longer necessary to avoid an 6139e0680481Safresh1 # infinite recursion, but it avoids unnecessary upgrading and downgrading in 6140e0680481Safresh1 # the intermediate computations. 6141e0680481Safresh1 6142*3d61058aSafresh1 my $upg = $class -> upgrade(); 6143*3d61058aSafresh1 my $dng = $class -> downgrade(); 6144*3d61058aSafresh1 $class -> upgrade(undef); 6145*3d61058aSafresh1 $class -> downgrade(undef); 6146*3d61058aSafresh1 6147*3d61058aSafresh1 # We also need to disable any set A or P on $x (_find_round_parameters took 6148*3d61058aSafresh1 # them already into account), since these would interfere, too. 6149*3d61058aSafresh1 6150*3d61058aSafresh1 $x->{accuracy} = undef; 6151*3d61058aSafresh1 $x->{precision} = undef; 6152b8851fccSafresh1 61539f11ffb7Safresh1 my ($limit, $v, $u, $below, $factor, $next, $over); 6154b8851fccSafresh1 61559f11ffb7Safresh1 $u = $x->copy()->blog(undef, $scale)->bmul($y); 61569f11ffb7Safresh1 my $do_invert = ($u->{sign} eq '-'); 6157e0680481Safresh1 $u = $u->bneg() if $do_invert; 61589f11ffb7Safresh1 $v = $class->bone(); # 1 61599f11ffb7Safresh1 $factor = $class->new(2); # 2 6160e0680481Safresh1 $x = $x->bone(); # first term: 1 61619f11ffb7Safresh1 61629f11ffb7Safresh1 $below = $v->copy(); 61639f11ffb7Safresh1 $over = $u->copy(); 61649f11ffb7Safresh1 61659f11ffb7Safresh1 $limit = $class->new("1E-". ($scale-1)); 61669f11ffb7Safresh1 while (3 < 5) { 61679f11ffb7Safresh1 # we calculate the next term, and add it to the last 61689f11ffb7Safresh1 # when the next term is below our limit, it won't affect the outcome 61699f11ffb7Safresh1 # anymore, so we stop: 61709f11ffb7Safresh1 $next = $over->copy()->bdiv($below, $scale); 6171b8851fccSafresh1 last if $next->bacmp($limit) <= 0; 6172e0680481Safresh1 $x = $x->badd($next); 6173b8851fccSafresh1 # calculate things for the next term 61749f11ffb7Safresh1 $over *= $u; 61759f11ffb7Safresh1 $below *= $factor; 6176e0680481Safresh1 $factor = $factor->binc(); 6177b8851fccSafresh1 61789f11ffb7Safresh1 last if $x->{sign} !~ /^[-+]$/; 6179b8851fccSafresh1 } 6180b8851fccSafresh1 61819f11ffb7Safresh1 if ($do_invert) { 61829f11ffb7Safresh1 my $x_copy = $x->copy(); 6183e0680481Safresh1 $x = $x->bone->bdiv($x_copy, $scale); 61849f11ffb7Safresh1 } 61859f11ffb7Safresh1 61869f11ffb7Safresh1 # shortcut to not run through _find_round_parameters again 6187b8851fccSafresh1 if (defined $params[0]) { 6188e0680481Safresh1 $x = $x->bround($params[0], $params[2]); # then round accordingly 6189b8851fccSafresh1 } else { 6190e0680481Safresh1 $x = $x->bfround($params[1], $params[2]); # then round accordingly 6191b8851fccSafresh1 } 6192b8851fccSafresh1 if ($fallback) { 61939f11ffb7Safresh1 # clear a/p after round, since user did not request it 6194*3d61058aSafresh1 $x->{accuracy} = undef; 6195*3d61058aSafresh1 $x->{precision} = undef; 6196b8851fccSafresh1 } 6197*3d61058aSafresh1 6198*3d61058aSafresh1 # Restore globals. We need to do it like this, because setting one 6199*3d61058aSafresh1 # undefines the other. 6200*3d61058aSafresh1 6201*3d61058aSafresh1 if (defined $ab) { 6202*3d61058aSafresh1 $class -> accuracy($ab); 6203*3d61058aSafresh1 } else { 6204*3d61058aSafresh1 $class -> precision($pb); 6205*3d61058aSafresh1 } 6206*3d61058aSafresh1 6207*3d61058aSafresh1 $class -> upgrade($upg); 6208*3d61058aSafresh1 $class -> downgrade($dng); 6209*3d61058aSafresh1 62109f11ffb7Safresh1 $x; 6211b8851fccSafresh1} 6212b8851fccSafresh1 6213e0680481Safresh1# These functions are only provided for backwards compabibility so that old 6214e0680481Safresh1# version of Math::BigRat etc. don't complain about missing them. 6215e0680481Safresh1 6216e0680481Safresh1sub _e_add { 6217e0680481Safresh1 my ($x, $y, $xs, $ys) = @_; 6218e0680481Safresh1 return $LIB -> _sadd($x, $xs, $y, $ys); 6219e0680481Safresh1} 6220e0680481Safresh1 6221e0680481Safresh1sub _e_sub { 6222e0680481Safresh1 my ($x, $y, $xs, $ys) = @_; 6223e0680481Safresh1 return $LIB -> _ssub($x, $xs, $y, $ys); 6224e0680481Safresh1} 6225e0680481Safresh1 6226b8851fccSafresh11; 6227b8851fccSafresh1 6228b8851fccSafresh1__END__ 6229b8851fccSafresh1 6230b8851fccSafresh1=pod 6231b8851fccSafresh1 6232b8851fccSafresh1=head1 NAME 6233b8851fccSafresh1 6234eac174f2Safresh1Math::BigFloat - arbitrary size floating point math package 6235b8851fccSafresh1 6236b8851fccSafresh1=head1 SYNOPSIS 6237b8851fccSafresh1 6238b8851fccSafresh1 use Math::BigFloat; 6239b8851fccSafresh1 62409f11ffb7Safresh1 # Configuration methods (may be used as class methods and instance methods) 6241b8851fccSafresh1 62429f11ffb7Safresh1 Math::BigFloat->accuracy(); # get class accuracy 62439f11ffb7Safresh1 Math::BigFloat->accuracy($n); # set class accuracy 62449f11ffb7Safresh1 Math::BigFloat->precision(); # get class precision 62459f11ffb7Safresh1 Math::BigFloat->precision($n); # set class precision 62469f11ffb7Safresh1 Math::BigFloat->round_mode(); # get class rounding mode 62479f11ffb7Safresh1 Math::BigFloat->round_mode($m); # set global round mode, must be one of 62489f11ffb7Safresh1 # 'even', 'odd', '+inf', '-inf', 'zero', 62499f11ffb7Safresh1 # 'trunc', or 'common' 6250b46d8ef2Safresh1 Math::BigFloat->config("lib"); # name of backend math library 6251b8851fccSafresh1 62529f11ffb7Safresh1 # Constructor methods (when the class methods below are used as instance 62539f11ffb7Safresh1 # methods, the value is assigned the invocand) 6254b8851fccSafresh1 62559f11ffb7Safresh1 $x = Math::BigFloat->new($str); # defaults to 0 62569f11ffb7Safresh1 $x = Math::BigFloat->new('0x123'); # from hexadecimal 6257eac174f2Safresh1 $x = Math::BigFloat->new('0o377'); # from octal 62589f11ffb7Safresh1 $x = Math::BigFloat->new('0b101'); # from binary 62599f11ffb7Safresh1 $x = Math::BigFloat->from_hex('0xc.afep+3'); # from hex 62609f11ffb7Safresh1 $x = Math::BigFloat->from_hex('cafe'); # ditto 62619f11ffb7Safresh1 $x = Math::BigFloat->from_oct('1.3267p-4'); # from octal 6262eac174f2Safresh1 $x = Math::BigFloat->from_oct('01.3267p-4'); # ditto 6263eac174f2Safresh1 $x = Math::BigFloat->from_oct('0o1.3267p-4'); # ditto 62649f11ffb7Safresh1 $x = Math::BigFloat->from_oct('0377'); # ditto 62659f11ffb7Safresh1 $x = Math::BigFloat->from_bin('0b1.1001p-4'); # from binary 62669f11ffb7Safresh1 $x = Math::BigFloat->from_bin('0101'); # ditto 626756d68f1eSafresh1 $x = Math::BigFloat->from_ieee754($b, "binary64"); # from IEEE-754 bytes 62689f11ffb7Safresh1 $x = Math::BigFloat->bzero(); # create a +0 62699f11ffb7Safresh1 $x = Math::BigFloat->bone(); # create a +1 62709f11ffb7Safresh1 $x = Math::BigFloat->bone('-'); # create a -1 62719f11ffb7Safresh1 $x = Math::BigFloat->binf(); # create a +inf 62729f11ffb7Safresh1 $x = Math::BigFloat->binf('-'); # create a -inf 62739f11ffb7Safresh1 $x = Math::BigFloat->bnan(); # create a Not-A-Number 62749f11ffb7Safresh1 $x = Math::BigFloat->bpi(); # returns pi 6275b8851fccSafresh1 62769f11ffb7Safresh1 $y = $x->copy(); # make a copy (unlike $y = $x) 62779f11ffb7Safresh1 $y = $x->as_int(); # return as BigInt 6278e0680481Safresh1 $y = $x->as_float(); # return as a Math::BigFloat 6279e0680481Safresh1 $y = $x->as_rat(); # return as a Math::BigRat 6280b8851fccSafresh1 62819f11ffb7Safresh1 # Boolean methods (these don't modify the invocand) 6282b8851fccSafresh1 62839f11ffb7Safresh1 $x->is_zero(); # if $x is 0 62849f11ffb7Safresh1 $x->is_one(); # if $x is +1 62859f11ffb7Safresh1 $x->is_one("+"); # ditto 62869f11ffb7Safresh1 $x->is_one("-"); # if $x is -1 62879f11ffb7Safresh1 $x->is_inf(); # if $x is +inf or -inf 62889f11ffb7Safresh1 $x->is_inf("+"); # if $x is +inf 62899f11ffb7Safresh1 $x->is_inf("-"); # if $x is -inf 62909f11ffb7Safresh1 $x->is_nan(); # if $x is NaN 6291b8851fccSafresh1 62929f11ffb7Safresh1 $x->is_positive(); # if $x > 0 62939f11ffb7Safresh1 $x->is_pos(); # ditto 62949f11ffb7Safresh1 $x->is_negative(); # if $x < 0 62959f11ffb7Safresh1 $x->is_neg(); # ditto 6296b8851fccSafresh1 62979f11ffb7Safresh1 $x->is_odd(); # if $x is odd 62989f11ffb7Safresh1 $x->is_even(); # if $x is even 62999f11ffb7Safresh1 $x->is_int(); # if $x is an integer 63009f11ffb7Safresh1 63019f11ffb7Safresh1 # Comparison methods 63029f11ffb7Safresh1 63039f11ffb7Safresh1 $x->bcmp($y); # compare numbers (undef, < 0, == 0, > 0) 63049f11ffb7Safresh1 $x->bacmp($y); # compare absolutely (undef, < 0, == 0, > 0) 63059f11ffb7Safresh1 $x->beq($y); # true if and only if $x == $y 63069f11ffb7Safresh1 $x->bne($y); # true if and only if $x != $y 63079f11ffb7Safresh1 $x->blt($y); # true if and only if $x < $y 63089f11ffb7Safresh1 $x->ble($y); # true if and only if $x <= $y 63099f11ffb7Safresh1 $x->bgt($y); # true if and only if $x > $y 63109f11ffb7Safresh1 $x->bge($y); # true if and only if $x >= $y 63119f11ffb7Safresh1 63129f11ffb7Safresh1 # Arithmetic methods 6313b8851fccSafresh1 6314b8851fccSafresh1 $x->bneg(); # negation 6315b8851fccSafresh1 $x->babs(); # absolute value 63169f11ffb7Safresh1 $x->bsgn(); # sign function (-1, 0, 1, or NaN) 6317b8851fccSafresh1 $x->bnorm(); # normalize (no-op) 63189f11ffb7Safresh1 $x->binc(); # increment $x by 1 63199f11ffb7Safresh1 $x->bdec(); # decrement $x by 1 6320b8851fccSafresh1 $x->badd($y); # addition (add $y to $x) 6321b8851fccSafresh1 $x->bsub($y); # subtraction (subtract $y from $x) 6322b8851fccSafresh1 $x->bmul($y); # multiplication (multiply $x by $y) 63239f11ffb7Safresh1 $x->bmuladd($y,$z); # $x = $x * $y + $z 63249f11ffb7Safresh1 $x->bdiv($y); # division (floored), set $x to quotient 6325b8851fccSafresh1 # return (quo,rem) or quo if scalar 63269f11ffb7Safresh1 $x->btdiv($y); # division (truncated), set $x to quotient 63279f11ffb7Safresh1 # return (quo,rem) or quo if scalar 63289f11ffb7Safresh1 $x->bmod($y); # modulus (x % y) 63299f11ffb7Safresh1 $x->btmod($y); # modulus (truncated) 63309f11ffb7Safresh1 $x->bmodinv($mod); # modular multiplicative inverse 63319f11ffb7Safresh1 $x->bmodpow($y,$mod); # modular exponentiation (($x ** $y) % $mod) 63329f11ffb7Safresh1 $x->bpow($y); # power of arguments (x ** y) 6333b8851fccSafresh1 $x->blog(); # logarithm of $x to base e (Euler's number) 63349f11ffb7Safresh1 $x->blog($base); # logarithm of $x to base $base (e.g., base 2) 6335b8851fccSafresh1 $x->bexp(); # calculate e ** $x where e is Euler's number 63369f11ffb7Safresh1 $x->bnok($y); # x over y (binomial coefficient n over k) 63379f11ffb7Safresh1 $x->bsin(); # sine 63389f11ffb7Safresh1 $x->bcos(); # cosine 63399f11ffb7Safresh1 $x->batan(); # inverse tangent 63409f11ffb7Safresh1 $x->batan2($y); # two-argument inverse tangent 6341b46d8ef2Safresh1 $x->bsqrt(); # calculate square root 6342b8851fccSafresh1 $x->broot($y); # $y'th root of $x (e.g. $y == 3 => cubic root) 6343b8851fccSafresh1 $x->bfac(); # factorial of $x (1*2*3*4*..$x) 6344b8851fccSafresh1 63459f11ffb7Safresh1 $x->blsft($n); # left shift $n places in base 2 63469f11ffb7Safresh1 $x->blsft($n,$b); # left shift $n places in base $b 63479f11ffb7Safresh1 # returns (quo,rem) or quo (scalar context) 63489f11ffb7Safresh1 $x->brsft($n); # right shift $n places in base 2 63499f11ffb7Safresh1 $x->brsft($n,$b); # right shift $n places in base $b 63509f11ffb7Safresh1 # returns (quo,rem) or quo (scalar context) 6351b8851fccSafresh1 63529f11ffb7Safresh1 # Bitwise methods 63539f11ffb7Safresh1 6354*3d61058aSafresh1 $x->bblsft($y); # bitwise left shift 6355*3d61058aSafresh1 $x->bbrsft($y); # bitwise right shift 63569f11ffb7Safresh1 $x->band($y); # bitwise and 63579f11ffb7Safresh1 $x->bior($y); # bitwise inclusive or 63589f11ffb7Safresh1 $x->bxor($y); # bitwise exclusive or 63599f11ffb7Safresh1 $x->bnot(); # bitwise not (two's complement) 63609f11ffb7Safresh1 63619f11ffb7Safresh1 # Rounding methods 63629f11ffb7Safresh1 $x->round($A,$P,$mode); # round to accuracy or precision using 63639f11ffb7Safresh1 # rounding mode $mode 63649f11ffb7Safresh1 $x->bround($n); # accuracy: preserve $n digits 63659f11ffb7Safresh1 $x->bfround($n); # $n > 0: round to $nth digit left of dec. point 63669f11ffb7Safresh1 # $n < 0: round to $nth digit right of dec. point 63679f11ffb7Safresh1 $x->bfloor(); # round towards minus infinity 63689f11ffb7Safresh1 $x->bceil(); # round towards plus infinity 6369b8851fccSafresh1 $x->bint(); # round towards zero 6370b8851fccSafresh1 63719f11ffb7Safresh1 # Other mathematical methods 6372b8851fccSafresh1 63739f11ffb7Safresh1 $x->bgcd($y); # greatest common divisor 63749f11ffb7Safresh1 $x->blcm($y); # least common multiple 6375b8851fccSafresh1 63769f11ffb7Safresh1 # Object property methods (do not modify the invocand) 6377b8851fccSafresh1 63789f11ffb7Safresh1 $x->sign(); # the sign, either +, - or NaN 63799f11ffb7Safresh1 $x->digit($n); # the nth digit, counting from the right 63809f11ffb7Safresh1 $x->digit(-$n); # the nth digit, counting from the left 63819f11ffb7Safresh1 $x->length(); # return number of digits in number 63829f11ffb7Safresh1 ($xl,$f) = $x->length(); # length of number and length of fraction 63839f11ffb7Safresh1 # part, latter is always 0 digits long 63849f11ffb7Safresh1 # for Math::BigInt objects 63859f11ffb7Safresh1 $x->mantissa(); # return (signed) mantissa as BigInt 6386b8851fccSafresh1 $x->exponent(); # return exponent as BigInt 6387b8851fccSafresh1 $x->parts(); # return (mantissa,exponent) as BigInt 63889f11ffb7Safresh1 $x->sparts(); # mantissa and exponent (as integers) 63899f11ffb7Safresh1 $x->nparts(); # mantissa and exponent (normalised) 63909f11ffb7Safresh1 $x->eparts(); # mantissa and exponent (engineering notation) 63919f11ffb7Safresh1 $x->dparts(); # integer and fraction part 6392eac174f2Safresh1 $x->fparts(); # numerator and denominator 6393eac174f2Safresh1 $x->numerator(); # numerator 6394eac174f2Safresh1 $x->denominator(); # denominator 6395b8851fccSafresh1 63969f11ffb7Safresh1 # Conversion methods (do not modify the invocand) 6397b8851fccSafresh1 63989f11ffb7Safresh1 $x->bstr(); # decimal notation, possibly zero padded 63999f11ffb7Safresh1 $x->bsstr(); # string in scientific notation with integers 64009f11ffb7Safresh1 $x->bnstr(); # string in normalized notation 64019f11ffb7Safresh1 $x->bestr(); # string in engineering notation 64029f11ffb7Safresh1 $x->bdstr(); # string in decimal notation 6403e0680481Safresh1 $x->bfstr(); # string in fractional notation 6404e0680481Safresh1 64059f11ffb7Safresh1 $x->as_hex(); # as signed hexadecimal string with prefixed 0x 64069f11ffb7Safresh1 $x->as_bin(); # as signed binary string with prefixed 0b 64079f11ffb7Safresh1 $x->as_oct(); # as signed octal string with prefixed 0 640856d68f1eSafresh1 $x->to_ieee754($format); # to bytes encoded according to IEEE 754-2008 6409b8851fccSafresh1 64109f11ffb7Safresh1 # Other conversion methods 64119f11ffb7Safresh1 64129f11ffb7Safresh1 $x->numify(); # return as scalar (might overflow or underflow) 6413b8851fccSafresh1 6414b8851fccSafresh1=head1 DESCRIPTION 6415b8851fccSafresh1 64169f11ffb7Safresh1Math::BigFloat provides support for arbitrary precision floating point. 64179f11ffb7Safresh1Overloading is also provided for Perl operators. 64189f11ffb7Safresh1 6419b8851fccSafresh1All operators (including basic math operations) are overloaded if you 6420b8851fccSafresh1declare your big floating point numbers as 6421b8851fccSafresh1 64229f11ffb7Safresh1 $x = Math::BigFloat -> new('12_3.456_789_123_456_789E-2'); 6423b8851fccSafresh1 6424b8851fccSafresh1Operations with overloaded operators preserve the arguments, which is 6425b8851fccSafresh1exactly what you expect. 6426b8851fccSafresh1 6427b8851fccSafresh1=head2 Input 6428b8851fccSafresh1 64299f11ffb7Safresh1Input values to these routines may be any scalar number or string that looks 6430eac174f2Safresh1like a number. Anything that is accepted by Perl as a literal numeric constant 6431eac174f2Safresh1should be accepted by this module. 6432b8851fccSafresh1 6433b8851fccSafresh1=over 6434b8851fccSafresh1 6435b8851fccSafresh1=item * 6436b8851fccSafresh1 64379f11ffb7Safresh1Leading and trailing whitespace is ignored. 6438b8851fccSafresh1 6439b8851fccSafresh1=item * 6440b8851fccSafresh1 6441eac174f2Safresh1Leading zeros are ignored, except for floating point numbers with a binary 6442eac174f2Safresh1exponent, in which case the number is interpreted as an octal floating point 6443eac174f2Safresh1number. For example, "01.4p+0" gives 1.5, "00.4p+0" gives 0.5, but "0.4p+0" 6444eac174f2Safresh1gives a NaN. And while "0377" gives 255, "0377p0" gives 255. 6445b8851fccSafresh1 6446b8851fccSafresh1=item * 6447b8851fccSafresh1 6448eac174f2Safresh1If the string has a "0x" or "0X" prefix, it is interpreted as a hexadecimal 6449eac174f2Safresh1number. 6450b8851fccSafresh1 6451b8851fccSafresh1=item * 6452b8851fccSafresh1 6453eac174f2Safresh1If the string has a "0o" or "0O" prefix, it is interpreted as an octal number. A 6454eac174f2Safresh1floating point literal with a "0" prefix is also interpreted as an octal number. 64559f11ffb7Safresh1 64569f11ffb7Safresh1=item * 64579f11ffb7Safresh1 6458eac174f2Safresh1If the string has a "0b" or "0B" prefix, it is interpreted as a binary number. 64599f11ffb7Safresh1 64609f11ffb7Safresh1=item * 64619f11ffb7Safresh1 6462eac174f2Safresh1Underline characters are allowed in the same way as they are allowed in literal 6463eac174f2Safresh1numerical constants. 64649f11ffb7Safresh1 64659f11ffb7Safresh1=item * 64669f11ffb7Safresh1 64679f11ffb7Safresh1If the string can not be interpreted, NaN is returned. 6468b8851fccSafresh1 6469eac174f2Safresh1=item * 6470b8851fccSafresh1 6471eac174f2Safresh1For hexadecimal, octal, and binary floating point numbers, the exponent must be 6472eac174f2Safresh1separated from the significand (mantissa) by the letter "p" or "P", not "e" or 6473eac174f2Safresh1"E" as with decimal numbers. 6474eac174f2Safresh1 6475eac174f2Safresh1=back 6476b8851fccSafresh1 64779f11ffb7Safresh1Some examples of valid string input 6478b8851fccSafresh1 64799f11ffb7Safresh1 Input string Resulting value 6480eac174f2Safresh1 64819f11ffb7Safresh1 123 123 64829f11ffb7Safresh1 1.23e2 123 64839f11ffb7Safresh1 12300e-2 123 6484eac174f2Safresh1 64859f11ffb7Safresh1 67_538_754 67538754 64869f11ffb7Safresh1 -4_5_6.7_8_9e+0_1_0 -4567890000000 6487eac174f2Safresh1 6488eac174f2Safresh1 0x13a 314 6489eac174f2Safresh1 0x13ap0 314 6490eac174f2Safresh1 0x1.3ap+8 314 6491eac174f2Safresh1 0x0.00013ap+24 314 6492eac174f2Safresh1 0x13a000p-12 314 6493eac174f2Safresh1 6494eac174f2Safresh1 0o472 314 6495eac174f2Safresh1 0o1.164p+8 314 6496eac174f2Safresh1 0o0.0001164p+20 314 6497eac174f2Safresh1 0o1164000p-10 314 6498eac174f2Safresh1 6499eac174f2Safresh1 0472 472 Note! 6500eac174f2Safresh1 01.164p+8 314 6501eac174f2Safresh1 00.0001164p+20 314 6502eac174f2Safresh1 01164000p-10 314 6503eac174f2Safresh1 6504eac174f2Safresh1 0b100111010 314 6505eac174f2Safresh1 0b1.0011101p+8 314 6506eac174f2Safresh1 0b0.00010011101p+12 314 6507eac174f2Safresh1 0b100111010000p-3 314 6508eac174f2Safresh1 65099f11ffb7Safresh1 0x1.921fb5p+1 3.14159262180328369140625e+0 6510eac174f2Safresh1 0o1.2677025p1 2.71828174591064453125 6511eac174f2Safresh1 01.2677025p1 2.71828174591064453125 65129f11ffb7Safresh1 0b1.1001p-4 9.765625e-2 6513b8851fccSafresh1 6514b8851fccSafresh1=head2 Output 6515b8851fccSafresh1 65169f11ffb7Safresh1Output values are usually Math::BigFloat objects. 6517b8851fccSafresh1 65189f11ffb7Safresh1Boolean operators C<is_zero()>, C<is_one()>, C<is_inf()>, etc. return true or 65199f11ffb7Safresh1false. 6520b8851fccSafresh1 65219f11ffb7Safresh1Comparison operators C<bcmp()> and C<bacmp()>) return -1, 0, 1, or 65229f11ffb7Safresh1undef. 6523b8851fccSafresh1 6524b8851fccSafresh1=head1 METHODS 6525b8851fccSafresh1 6526b8851fccSafresh1Math::BigFloat supports all methods that Math::BigInt supports, except it 65279f11ffb7Safresh1calculates non-integer results when possible. Please see L<Math::BigInt> for a 65289f11ffb7Safresh1full description of each method. Below are just the most important differences: 65299f11ffb7Safresh1 65309f11ffb7Safresh1=head2 Configuration methods 6531b8851fccSafresh1 6532b8851fccSafresh1=over 6533b8851fccSafresh1 6534b8851fccSafresh1=item accuracy() 6535b8851fccSafresh1 6536b8851fccSafresh1 $x->accuracy(5); # local for $x 6537b8851fccSafresh1 CLASS->accuracy(5); # global for all members of CLASS 6538b8851fccSafresh1 # Note: This also applies to new()! 6539b8851fccSafresh1 6540b8851fccSafresh1 $A = $x->accuracy(); # read out accuracy that affects $x 6541b8851fccSafresh1 $A = CLASS->accuracy(); # read out global accuracy 6542b8851fccSafresh1 6543b8851fccSafresh1Set or get the global or local accuracy, aka how many significant digits the 6544b8851fccSafresh1results have. If you set a global accuracy, then this also applies to new()! 6545b8851fccSafresh1 6546b8851fccSafresh1Warning! The accuracy I<sticks>, e.g. once you created a number under the 6547b8851fccSafresh1influence of C<< CLASS->accuracy($A) >>, all results from math operations with 6548b8851fccSafresh1that number will also be rounded. 6549b8851fccSafresh1 6550b8851fccSafresh1In most cases, you should probably round the results explicitly using one of 65519f11ffb7Safresh1L<Math::BigInt/round()>, L<Math::BigInt/bround()> or L<Math::BigInt/bfround()> 65529f11ffb7Safresh1or by passing the desired accuracy to the math operation as additional 65539f11ffb7Safresh1parameter: 6554b8851fccSafresh1 6555b8851fccSafresh1 my $x = Math::BigInt->new(30000); 6556b8851fccSafresh1 my $y = Math::BigInt->new(7); 6557b8851fccSafresh1 print scalar $x->copy()->bdiv($y, 2); # print 4300 6558b8851fccSafresh1 print scalar $x->copy()->bdiv($y)->bround(2); # print 4300 6559b8851fccSafresh1 6560b8851fccSafresh1=item precision() 6561b8851fccSafresh1 6562b8851fccSafresh1 $x->precision(-2); # local for $x, round at the second 6563b8851fccSafresh1 # digit right of the dot 6564b8851fccSafresh1 $x->precision(2); # ditto, round at the second digit 6565b8851fccSafresh1 # left of the dot 6566b8851fccSafresh1 6567b8851fccSafresh1 CLASS->precision(5); # Global for all members of CLASS 6568b8851fccSafresh1 # This also applies to new()! 6569b8851fccSafresh1 CLASS->precision(-5); # ditto 6570b8851fccSafresh1 6571b8851fccSafresh1 $P = CLASS->precision(); # read out global precision 6572b8851fccSafresh1 $P = $x->precision(); # read out precision that affects $x 6573b8851fccSafresh1 6574b8851fccSafresh1Note: You probably want to use L</accuracy()> instead. With L</accuracy()> you 6575b8851fccSafresh1set the number of digits each result should have, with L</precision()> you 6576b8851fccSafresh1set the place where to round! 6577b8851fccSafresh1 65789f11ffb7Safresh1=back 65799f11ffb7Safresh1 65809f11ffb7Safresh1=head2 Constructor methods 65819f11ffb7Safresh1 65829f11ffb7Safresh1=over 65839f11ffb7Safresh1 65849f11ffb7Safresh1=item from_hex() 65859f11ffb7Safresh1 65869f11ffb7Safresh1 $x -> from_hex("0x1.921fb54442d18p+1"); 65879f11ffb7Safresh1 $x = Math::BigFloat -> from_hex("0x1.921fb54442d18p+1"); 65889f11ffb7Safresh1 65899f11ffb7Safresh1Interpret input as a hexadecimal string.A prefix ("0x", "x", ignoring case) is 65909f11ffb7Safresh1optional. A single underscore character ("_") may be placed between any two 65919f11ffb7Safresh1digits. If the input is invalid, a NaN is returned. The exponent is in base 2 65929f11ffb7Safresh1using decimal digits. 65939f11ffb7Safresh1 65949f11ffb7Safresh1If called as an instance method, the value is assigned to the invocand. 65959f11ffb7Safresh1 65969f11ffb7Safresh1=item from_oct() 65979f11ffb7Safresh1 65989f11ffb7Safresh1 $x -> from_oct("1.3267p-4"); 65999f11ffb7Safresh1 $x = Math::BigFloat -> from_oct("1.3267p-4"); 66009f11ffb7Safresh1 66019f11ffb7Safresh1Interpret input as an octal string. A single underscore character ("_") may be 66029f11ffb7Safresh1placed between any two digits. If the input is invalid, a NaN is returned. The 66039f11ffb7Safresh1exponent is in base 2 using decimal digits. 66049f11ffb7Safresh1 66059f11ffb7Safresh1If called as an instance method, the value is assigned to the invocand. 66069f11ffb7Safresh1 66079f11ffb7Safresh1=item from_bin() 66089f11ffb7Safresh1 66099f11ffb7Safresh1 $x -> from_bin("0b1.1001p-4"); 66109f11ffb7Safresh1 $x = Math::BigFloat -> from_bin("0b1.1001p-4"); 66119f11ffb7Safresh1 66129f11ffb7Safresh1Interpret input as a hexadecimal string. A prefix ("0b" or "b", ignoring case) 66139f11ffb7Safresh1is optional. A single underscore character ("_") may be placed between any two 66149f11ffb7Safresh1digits. If the input is invalid, a NaN is returned. The exponent is in base 2 66159f11ffb7Safresh1using decimal digits. 66169f11ffb7Safresh1 66179f11ffb7Safresh1If called as an instance method, the value is assigned to the invocand. 66189f11ffb7Safresh1 661956d68f1eSafresh1=item from_ieee754() 662056d68f1eSafresh1 662156d68f1eSafresh1Interpret the input as a value encoded as described in IEEE754-2008. The input 662256d68f1eSafresh1can be given as a byte string, hex string or binary string. The input is 662356d68f1eSafresh1assumed to be in big-endian byte-order. 662456d68f1eSafresh1 662556d68f1eSafresh1 # both $dbl and $mbf are 3.141592... 662656d68f1eSafresh1 $bytes = "\x40\x09\x21\xfb\x54\x44\x2d\x18"; 662756d68f1eSafresh1 $dbl = unpack "d>", $bytes; 662856d68f1eSafresh1 $mbf = Math::BigFloat -> from_ieee754($bytes, "binary64"); 662956d68f1eSafresh1 66309f11ffb7Safresh1=item bpi() 66319f11ffb7Safresh1 66329f11ffb7Safresh1 print Math::BigFloat->bpi(100), "\n"; 66339f11ffb7Safresh1 66349f11ffb7Safresh1Calculate PI to N digits (including the 3 before the dot). The result is 66359f11ffb7Safresh1rounded according to the current rounding mode, which defaults to "even". 66369f11ffb7Safresh1 66379f11ffb7Safresh1This method was added in v1.87 of Math::BigInt (June 2007). 66389f11ffb7Safresh1 66399f11ffb7Safresh1=back 66409f11ffb7Safresh1 66419f11ffb7Safresh1=head2 Arithmetic methods 66429f11ffb7Safresh1 66439f11ffb7Safresh1=over 66449f11ffb7Safresh1 66459f11ffb7Safresh1=item bmuladd() 66469f11ffb7Safresh1 66479f11ffb7Safresh1 $x->bmuladd($y,$z); 66489f11ffb7Safresh1 66499f11ffb7Safresh1Multiply $x by $y, and then add $z to the result. 66509f11ffb7Safresh1 66519f11ffb7Safresh1This method was added in v1.87 of Math::BigInt (June 2007). 66529f11ffb7Safresh1 6653*3d61058aSafresh1=item binv() 6654*3d61058aSafresh1 6655*3d61058aSafresh1 $x->binv(); 6656*3d61058aSafresh1 6657*3d61058aSafresh1Invert the value of $x, i.e., compute 1/$x. 6658*3d61058aSafresh1 6659b8851fccSafresh1=item bdiv() 6660b8851fccSafresh1 6661b8851fccSafresh1 $q = $x->bdiv($y); 6662b8851fccSafresh1 ($q, $r) = $x->bdiv($y); 6663b8851fccSafresh1 6664b8851fccSafresh1In scalar context, divides $x by $y and returns the result to the given or 6665b8851fccSafresh1default accuracy/precision. In list context, does floored division 6666b8851fccSafresh1(F-division), returning an integer $q and a remainder $r so that $x = $q * $y + 6667b46d8ef2Safresh1$r. The remainer (modulo) is equal to what is returned by C<< $x->bmod($y) >>. 6668b8851fccSafresh1 6669b8851fccSafresh1=item bmod() 6670b8851fccSafresh1 6671b8851fccSafresh1 $x->bmod($y); 6672b8851fccSafresh1 6673b8851fccSafresh1Returns $x modulo $y. When $x is finite, and $y is finite and non-zero, the 6674b8851fccSafresh1result is identical to the remainder after floored division (F-division). If, 6675b8851fccSafresh1in addition, both $x and $y are integers, the result is identical to the result 6676b8851fccSafresh1from Perl's % operator. 6677b8851fccSafresh1 6678b8851fccSafresh1=item bexp() 6679b8851fccSafresh1 6680b8851fccSafresh1 $x->bexp($accuracy); # calculate e ** X 6681b8851fccSafresh1 6682b8851fccSafresh1Calculates the expression C<e ** $x> where C<e> is Euler's number. 6683b8851fccSafresh1 6684b8851fccSafresh1This method was added in v1.82 of Math::BigInt (April 2007). 6685b8851fccSafresh1 6686b8851fccSafresh1=item bnok() 6687b8851fccSafresh1 6688b8851fccSafresh1 $x->bnok($y); # x over y (binomial coefficient n over k) 6689b8851fccSafresh1 6690b8851fccSafresh1Calculates the binomial coefficient n over k, also called the "choose" 6691b8851fccSafresh1function. The result is equivalent to: 6692b8851fccSafresh1 6693b8851fccSafresh1 ( n ) n! 6694b8851fccSafresh1 | - | = ------- 6695b8851fccSafresh1 ( k ) k!(n-k)! 6696b8851fccSafresh1 6697b8851fccSafresh1This method was added in v1.84 of Math::BigInt (April 2007). 6698b8851fccSafresh1 66999f11ffb7Safresh1=item bsin() 6700b8851fccSafresh1 67019f11ffb7Safresh1 my $x = Math::BigFloat->new(1); 67029f11ffb7Safresh1 print $x->bsin(100), "\n"; 6703b8851fccSafresh1 67049f11ffb7Safresh1Calculate the sinus of $x, modifying $x in place. 6705b8851fccSafresh1 6706b8851fccSafresh1This method was added in v1.87 of Math::BigInt (June 2007). 6707b8851fccSafresh1 6708b8851fccSafresh1=item bcos() 6709b8851fccSafresh1 6710b8851fccSafresh1 my $x = Math::BigFloat->new(1); 6711b8851fccSafresh1 print $x->bcos(100), "\n"; 6712b8851fccSafresh1 6713b8851fccSafresh1Calculate the cosinus of $x, modifying $x in place. 6714b8851fccSafresh1 6715b8851fccSafresh1This method was added in v1.87 of Math::BigInt (June 2007). 6716b8851fccSafresh1 67179f11ffb7Safresh1=item batan() 6718b8851fccSafresh1 6719b8851fccSafresh1 my $x = Math::BigFloat->new(1); 67209f11ffb7Safresh1 print $x->batan(100), "\n"; 6721b8851fccSafresh1 67229f11ffb7Safresh1Calculate the arcus tanges of $x, modifying $x in place. See also L</batan2()>. 6723b8851fccSafresh1 6724b8851fccSafresh1This method was added in v1.87 of Math::BigInt (June 2007). 6725b8851fccSafresh1 6726b8851fccSafresh1=item batan2() 6727b8851fccSafresh1 6728b8851fccSafresh1 my $y = Math::BigFloat->new(2); 6729b8851fccSafresh1 my $x = Math::BigFloat->new(3); 6730b8851fccSafresh1 print $y->batan2($x), "\n"; 6731b8851fccSafresh1 6732b8851fccSafresh1Calculate the arcus tanges of C<$y> divided by C<$x>, modifying $y in place. 6733b8851fccSafresh1See also L</batan()>. 6734b8851fccSafresh1 6735b8851fccSafresh1This method was added in v1.87 of Math::BigInt (June 2007). 6736b8851fccSafresh1 6737b8851fccSafresh1=item as_float() 6738b8851fccSafresh1 6739b8851fccSafresh1This method is called when Math::BigFloat encounters an object it doesn't know 6740b8851fccSafresh1how to handle. For instance, assume $x is a Math::BigFloat, or subclass 6741b8851fccSafresh1thereof, and $y is defined, but not a Math::BigFloat, or subclass thereof. If 6742b8851fccSafresh1you do 6743b8851fccSafresh1 6744b8851fccSafresh1 $x -> badd($y); 6745b8851fccSafresh1 6746b8851fccSafresh1$y needs to be converted into an object that $x can deal with. This is done by 6747b8851fccSafresh1first checking if $y is something that $x might be upgraded to. If that is the 6748b8851fccSafresh1case, no further attempts are made. The next is to see if $y supports the 6749b8851fccSafresh1method C<as_float()>. The method C<as_float()> is expected to return either an 6750b8851fccSafresh1object that has the same class as $x, a subclass thereof, or a string that 6751b8851fccSafresh1C<ref($x)-E<gt>new()> can parse to create an object. 6752b8851fccSafresh1 6753b8851fccSafresh1In Math::BigFloat, C<as_float()> has the same effect as C<copy()>. 6754b8851fccSafresh1 675556d68f1eSafresh1=item to_ieee754() 675656d68f1eSafresh1 675756d68f1eSafresh1Encodes the invocand as a byte string in the given format as specified in IEEE 675856d68f1eSafresh1754-2008. Note that the encoded value is the nearest possible representation of 675956d68f1eSafresh1the value. This value might not be exactly the same as the value in the 676056d68f1eSafresh1invocand. 676156d68f1eSafresh1 676256d68f1eSafresh1 # $x = 3.1415926535897932385 676356d68f1eSafresh1 $x = Math::BigFloat -> bpi(30); 676456d68f1eSafresh1 676556d68f1eSafresh1 $b = $x -> to_ieee754("binary64"); # encode as 8 bytes 676656d68f1eSafresh1 $h = unpack "H*", $b; # "400921fb54442d18" 676756d68f1eSafresh1 676856d68f1eSafresh1 # 3.141592653589793115997963... 676956d68f1eSafresh1 $y = Math::BigFloat -> from_ieee754($h, "binary64"); 677056d68f1eSafresh1 677156d68f1eSafresh1All binary formats in IEEE 754-2008 are accepted. For convenience, som aliases 677256d68f1eSafresh1are recognized: "half" for "binary16", "single" for "binary32", "double" for 677356d68f1eSafresh1"binary64", "quadruple" for "binary128", "octuple" for "binary256", and 677456d68f1eSafresh1"sexdecuple" for "binary512". 677556d68f1eSafresh1 677656d68f1eSafresh1See also L<https://en.wikipedia.org/wiki/IEEE_754>. 677756d68f1eSafresh1 67789f11ffb7Safresh1=back 6779b8851fccSafresh1 67809f11ffb7Safresh1=head2 ACCURACY AND PRECISION 6781b8851fccSafresh1 67829f11ffb7Safresh1See also: L<Rounding|/Rounding>. 6783b8851fccSafresh1 67849f11ffb7Safresh1Math::BigFloat supports both precision (rounding to a certain place before or 67859f11ffb7Safresh1after the dot) and accuracy (rounding to a certain number of digits). For a 67869f11ffb7Safresh1full documentation, examples and tips on these topics please see the large 67879f11ffb7Safresh1section about rounding in L<Math::BigInt>. 6788b8851fccSafresh1 67899f11ffb7Safresh1Since things like C<sqrt(2)> or C<1 / 3> must presented with a limited 67909f11ffb7Safresh1accuracy lest a operation consumes all resources, each operation produces 67919f11ffb7Safresh1no more than the requested number of digits. 6792b8851fccSafresh1 67939f11ffb7Safresh1If there is no global precision or accuracy set, B<and> the operation in 67949f11ffb7Safresh1question was not called with a requested precision or accuracy, B<and> the 67959f11ffb7Safresh1input $x has no accuracy or precision set, then a fallback parameter will 67969f11ffb7Safresh1be used. For historical reasons, it is called C<div_scale> and can be accessed 67979f11ffb7Safresh1via: 6798b8851fccSafresh1 67999f11ffb7Safresh1 $d = Math::BigFloat->div_scale(); # query 68009f11ffb7Safresh1 Math::BigFloat->div_scale($n); # set to $n digits 6801b8851fccSafresh1 68029f11ffb7Safresh1The default value for C<div_scale> is 40. 6803b8851fccSafresh1 68049f11ffb7Safresh1In case the result of one operation has more digits than specified, 68059f11ffb7Safresh1it is rounded. The rounding mode taken is either the default mode, or the one 68069f11ffb7Safresh1supplied to the operation after the I<scale>: 6807b8851fccSafresh1 68089f11ffb7Safresh1 $x = Math::BigFloat->new(2); 68099f11ffb7Safresh1 Math::BigFloat->accuracy(5); # 5 digits max 68109f11ffb7Safresh1 $y = $x->copy()->bdiv(3); # gives 0.66667 68119f11ffb7Safresh1 $y = $x->copy()->bdiv(3,6); # gives 0.666667 68129f11ffb7Safresh1 $y = $x->copy()->bdiv(3,6,undef,'odd'); # gives 0.666667 68139f11ffb7Safresh1 Math::BigFloat->round_mode('zero'); 68149f11ffb7Safresh1 $y = $x->copy()->bdiv(3,6); # will also give 0.666667 6815b8851fccSafresh1 6816e0680481Safresh1Note that C<< Math::BigFloat->accuracy() >> and 6817e0680481Safresh1C<< Math::BigFloat->precision() >> set the global variables, and thus B<any> 6818e0680481Safresh1newly created number will be subject to the global rounding B<immediately>. This 6819e0680481Safresh1means that in the examples above, the C<3> as argument to C<bdiv()> will also 6820e0680481Safresh1get an accuracy of B<5>. 6821b8851fccSafresh1 68229f11ffb7Safresh1It is less confusing to either calculate the result fully, and afterwards 68239f11ffb7Safresh1round it explicitly, or use the additional parameters to the math 68249f11ffb7Safresh1functions like so: 68259f11ffb7Safresh1 68269f11ffb7Safresh1 use Math::BigFloat; 68279f11ffb7Safresh1 $x = Math::BigFloat->new(2); 68289f11ffb7Safresh1 $y = $x->copy()->bdiv(3); 68299f11ffb7Safresh1 print $y->bround(5),"\n"; # gives 0.66667 68309f11ffb7Safresh1 68319f11ffb7Safresh1 or 68329f11ffb7Safresh1 68339f11ffb7Safresh1 use Math::BigFloat; 68349f11ffb7Safresh1 $x = Math::BigFloat->new(2); 68359f11ffb7Safresh1 $y = $x->copy()->bdiv(3,5); # gives 0.66667 68369f11ffb7Safresh1 print "$y\n"; 68379f11ffb7Safresh1 68389f11ffb7Safresh1=head2 Rounding 68399f11ffb7Safresh1 68409f11ffb7Safresh1=over 68419f11ffb7Safresh1 68429f11ffb7Safresh1=item bfround ( +$scale ) 68439f11ffb7Safresh1 68449f11ffb7Safresh1Rounds to the $scale'th place left from the '.', counting from the dot. 68459f11ffb7Safresh1The first digit is numbered 1. 68469f11ffb7Safresh1 68479f11ffb7Safresh1=item bfround ( -$scale ) 68489f11ffb7Safresh1 68499f11ffb7Safresh1Rounds to the $scale'th place right from the '.', counting from the dot. 68509f11ffb7Safresh1 68519f11ffb7Safresh1=item bfround ( 0 ) 68529f11ffb7Safresh1 68539f11ffb7Safresh1Rounds to an integer. 68549f11ffb7Safresh1 68559f11ffb7Safresh1=item bround ( +$scale ) 68569f11ffb7Safresh1 68579f11ffb7Safresh1Preserves accuracy to $scale digits from the left (aka significant digits) and 68589f11ffb7Safresh1pads the rest with zeros. If the number is between 1 and -1, the significant 68599f11ffb7Safresh1digits count from the first non-zero after the '.' 68609f11ffb7Safresh1 68619f11ffb7Safresh1=item bround ( -$scale ) and bround ( 0 ) 68629f11ffb7Safresh1 68639f11ffb7Safresh1These are effectively no-ops. 6864b8851fccSafresh1 6865b8851fccSafresh1=back 6866b8851fccSafresh1 68679f11ffb7Safresh1All rounding functions take as a second parameter a rounding mode from one of 68689f11ffb7Safresh1the following: 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'. 68699f11ffb7Safresh1 68709f11ffb7Safresh1The default rounding mode is 'even'. By using 68719f11ffb7Safresh1C<< Math::BigFloat->round_mode($round_mode); >> you can get and set the default 68729f11ffb7Safresh1mode for subsequent rounding. The usage of C<$Math::BigFloat::$round_mode> is 68739f11ffb7Safresh1no longer supported. 68749f11ffb7Safresh1The second parameter to the round functions then overrides the default 68759f11ffb7Safresh1temporarily. 68769f11ffb7Safresh1 68779f11ffb7Safresh1The C<as_number()> function returns a BigInt from a Math::BigFloat. It uses 68789f11ffb7Safresh1'trunc' as rounding mode to make it equivalent to: 68799f11ffb7Safresh1 68809f11ffb7Safresh1 $x = 2.5; 68819f11ffb7Safresh1 $y = int($x) + 2; 68829f11ffb7Safresh1 68839f11ffb7Safresh1You can override this by passing the desired rounding mode as parameter to 68849f11ffb7Safresh1C<as_number()>: 68859f11ffb7Safresh1 68869f11ffb7Safresh1 $x = Math::BigFloat->new(2.5); 68879f11ffb7Safresh1 $y = $x->as_number('odd'); # $y = 3 68889f11ffb7Safresh1 6889eac174f2Safresh1=head1 NUMERIC LITERALS 6890b8851fccSafresh1 6891eac174f2Safresh1After C<use Math::BigFloat ':constant'> all numeric literals in the given scope 6892eac174f2Safresh1are converted to C<Math::BigFloat> objects. This conversion happens at compile 6893eac174f2Safresh1time. 6894b8851fccSafresh1 6895eac174f2Safresh1For example, 6896b8851fccSafresh1 6897eac174f2Safresh1 perl -MMath::BigFloat=:constant -le 'print 2e-150' 6898b8851fccSafresh1 6899eac174f2Safresh1prints the exact value of C<2e-150>. Note that without conversion of constants 6900eac174f2Safresh1the expression C<2e-150> is calculated using Perl scalars, which leads to an 6901eac174f2Safresh1inaccuracte result. 6902b8851fccSafresh1 6903eac174f2Safresh1Note that strings are not affected, so that 6904eac174f2Safresh1 6905eac174f2Safresh1 use Math::BigFloat qw/:constant/; 6906eac174f2Safresh1 6907eac174f2Safresh1 $y = "1234567890123456789012345678901234567890" 6908eac174f2Safresh1 + "123456789123456789"; 6909eac174f2Safresh1 6910eac174f2Safresh1does not give you what you expect. You need an explicit Math::BigFloat->new() 6911eac174f2Safresh1around at least one of the operands. You should also quote large constants to 6912eac174f2Safresh1prevent loss of precision: 6913eac174f2Safresh1 6914eac174f2Safresh1 use Math::BigFloat; 6915eac174f2Safresh1 6916eac174f2Safresh1 $x = Math::BigFloat->new("1234567889123456789123456789123456789"); 6917eac174f2Safresh1 6918eac174f2Safresh1Without the quotes Perl converts the large number to a floating point constant 6919eac174f2Safresh1at compile time, and then converts the result to a Math::BigFloat object at 6920eac174f2Safresh1runtime, which results in an inaccurate result. 6921eac174f2Safresh1 6922eac174f2Safresh1=head2 Hexadecimal, octal, and binary floating point literals 6923eac174f2Safresh1 6924eac174f2Safresh1Perl (and this module) accepts hexadecimal, octal, and binary floating point 6925eac174f2Safresh1literals, but use them with care with Perl versions before v5.32.0, because some 6926eac174f2Safresh1versions of Perl silently give the wrong result. Below are some examples of 6927eac174f2Safresh1different ways to write the number decimal 314. 6928eac174f2Safresh1 6929eac174f2Safresh1Hexadecimal floating point literals: 6930eac174f2Safresh1 6931eac174f2Safresh1 0x1.3ap+8 0X1.3AP+8 6932eac174f2Safresh1 0x1.3ap8 0X1.3AP8 6933eac174f2Safresh1 0x13a0p-4 0X13A0P-4 6934eac174f2Safresh1 6935eac174f2Safresh1Octal floating point literals (with "0" prefix): 6936eac174f2Safresh1 6937eac174f2Safresh1 01.164p+8 01.164P+8 6938eac174f2Safresh1 01.164p8 01.164P8 6939eac174f2Safresh1 011640p-4 011640P-4 6940eac174f2Safresh1 6941eac174f2Safresh1Octal floating point literals (with "0o" prefix) (requires v5.34.0): 6942eac174f2Safresh1 6943eac174f2Safresh1 0o1.164p+8 0O1.164P+8 6944eac174f2Safresh1 0o1.164p8 0O1.164P8 6945eac174f2Safresh1 0o11640p-4 0O11640P-4 6946eac174f2Safresh1 6947eac174f2Safresh1Binary floating point literals: 6948eac174f2Safresh1 6949eac174f2Safresh1 0b1.0011101p+8 0B1.0011101P+8 6950eac174f2Safresh1 0b1.0011101p8 0B1.0011101P8 6951eac174f2Safresh1 0b10011101000p-2 0B10011101000P-2 6952b8851fccSafresh1 6953b8851fccSafresh1=head2 Math library 6954b8851fccSafresh1 6955b8851fccSafresh1Math with the numbers is done (by default) by a module called 6956b8851fccSafresh1Math::BigInt::Calc. This is equivalent to saying: 6957b8851fccSafresh1 6958eac174f2Safresh1 use Math::BigFloat lib => "Calc"; 6959b8851fccSafresh1 6960b8851fccSafresh1You can change this by using: 6961b8851fccSafresh1 6962eac174f2Safresh1 use Math::BigFloat lib => "GMP"; 6963b8851fccSafresh1 6964eac174f2Safresh1B<Note>: General purpose packages should not be explicit about the library to 6965eac174f2Safresh1use; let the script author decide which is best. 6966b8851fccSafresh1 6967b8851fccSafresh1Note: The keyword 'lib' will warn when the requested library could not be 6968b8851fccSafresh1loaded. To suppress the warning use 'try' instead: 6969b8851fccSafresh1 6970eac174f2Safresh1 use Math::BigFloat try => "GMP"; 6971b8851fccSafresh1 6972eac174f2Safresh1If your script works with huge numbers and Calc is too slow for them, you can 6973eac174f2Safresh1also for the loading of one of these libraries and if none of them can be used, 6974eac174f2Safresh1the code will die: 6975b8851fccSafresh1 6976eac174f2Safresh1 use Math::BigFloat only => "GMP,Pari"; 6977b8851fccSafresh1 6978eac174f2Safresh1The following would first try to find Math::BigInt::Foo, then Math::BigInt::Bar, 6979eac174f2Safresh1and when this also fails, revert to Math::BigInt::Calc: 6980b8851fccSafresh1 6981eac174f2Safresh1 use Math::BigFloat lib => "Foo,Math::BigInt::Bar"; 6982b8851fccSafresh1 6983b8851fccSafresh1See the respective low-level library documentation for further details. 6984b8851fccSafresh1 6985eac174f2Safresh1See L<Math::BigInt> for more details about using a different low-level library. 6986b8851fccSafresh1 6987b8851fccSafresh1=head1 EXPORTS 6988b8851fccSafresh1 6989e0680481Safresh1C<Math::BigFloat> exports nothing by default, but can export the C<bpi()> 6990e0680481Safresh1method: 6991b8851fccSafresh1 6992b8851fccSafresh1 use Math::BigFloat qw/bpi/; 6993b8851fccSafresh1 6994b8851fccSafresh1 print bpi(10), "\n"; 6995b8851fccSafresh1 6996b8851fccSafresh1=over 6997b8851fccSafresh1 6998b8851fccSafresh1=item stringify, bstr() 6999b8851fccSafresh1 7000b8851fccSafresh1Both stringify and bstr() now drop the leading '+'. The old code would return 7001b8851fccSafresh1'+1.23', the new returns '1.23'. See the documentation in L<Math::BigInt> for 7002b8851fccSafresh1reasoning and details. 7003b8851fccSafresh1 7004b8851fccSafresh1=item brsft() 7005b8851fccSafresh1 7006b8851fccSafresh1The following will probably not print what you expect: 7007b8851fccSafresh1 7008b8851fccSafresh1 my $c = Math::BigFloat->new('3.14159'); 7009b8851fccSafresh1 print $c->brsft(3,10),"\n"; # prints 0.00314153.1415 7010b8851fccSafresh1 7011b8851fccSafresh1It prints both quotient and remainder, since print calls C<brsft()> in list 7012b8851fccSafresh1context. Also, C<< $c->brsft() >> will modify $c, so be careful. 7013b8851fccSafresh1You probably want to use 7014b8851fccSafresh1 7015b8851fccSafresh1 print scalar $c->copy()->brsft(3,10),"\n"; 7016b8851fccSafresh1 # or if you really want to modify $c 7017b8851fccSafresh1 print scalar $c->brsft(3,10),"\n"; 7018b8851fccSafresh1 7019b8851fccSafresh1instead. 7020b8851fccSafresh1 7021b8851fccSafresh1=item Modifying and = 7022b8851fccSafresh1 7023b8851fccSafresh1Beware of: 7024b8851fccSafresh1 7025b8851fccSafresh1 $x = Math::BigFloat->new(5); 7026b8851fccSafresh1 $y = $x; 7027b8851fccSafresh1 7028b8851fccSafresh1It will not do what you think, e.g. making a copy of $x. Instead it just makes 7029b8851fccSafresh1a second reference to the B<same> object and stores it in $y. Thus anything 7030b8851fccSafresh1that modifies $x will modify $y (except overloaded math operators), and vice 7031b8851fccSafresh1versa. See L<Math::BigInt> for details and how to avoid that. 7032b8851fccSafresh1 7033b8851fccSafresh1=item precision() vs. accuracy() 7034b8851fccSafresh1 7035b8851fccSafresh1A common pitfall is to use L</precision()> when you want to round a result to 7036b8851fccSafresh1a certain number of digits: 7037b8851fccSafresh1 7038b8851fccSafresh1 use Math::BigFloat; 7039b8851fccSafresh1 7040b8851fccSafresh1 Math::BigFloat->precision(4); # does not do what you 7041b8851fccSafresh1 # think it does 7042b8851fccSafresh1 my $x = Math::BigFloat->new(12345); # rounds $x to "12000"! 7043b8851fccSafresh1 print "$x\n"; # print "12000" 7044b8851fccSafresh1 my $y = Math::BigFloat->new(3); # rounds $y to "0"! 7045b8851fccSafresh1 print "$y\n"; # print "0" 7046b8851fccSafresh1 $z = $x / $y; # 12000 / 0 => NaN! 7047b8851fccSafresh1 print "$z\n"; 7048b8851fccSafresh1 print $z->precision(),"\n"; # 4 7049b8851fccSafresh1 7050e0680481Safresh1Replacing L</precision()> with L</accuracy()> is probably not what you want, 7051e0680481Safresh1either: 7052b8851fccSafresh1 7053b8851fccSafresh1 use Math::BigFloat; 7054b8851fccSafresh1 7055b8851fccSafresh1 Math::BigFloat->accuracy(4); # enables global rounding: 7056b8851fccSafresh1 my $x = Math::BigFloat->new(123456); # rounded immediately 7057b8851fccSafresh1 # to "12350" 7058b8851fccSafresh1 print "$x\n"; # print "123500" 7059b8851fccSafresh1 my $y = Math::BigFloat->new(3); # rounded to "3 7060b8851fccSafresh1 print "$y\n"; # print "3" 7061b8851fccSafresh1 print $z = $x->copy()->bdiv($y),"\n"; # 41170 7062b8851fccSafresh1 print $z->accuracy(),"\n"; # 4 7063b8851fccSafresh1 7064b8851fccSafresh1What you want to use instead is: 7065b8851fccSafresh1 7066b8851fccSafresh1 use Math::BigFloat; 7067b8851fccSafresh1 7068b8851fccSafresh1 my $x = Math::BigFloat->new(123456); # no rounding 7069b8851fccSafresh1 print "$x\n"; # print "123456" 7070b8851fccSafresh1 my $y = Math::BigFloat->new(3); # no rounding 7071b8851fccSafresh1 print "$y\n"; # print "3" 7072b8851fccSafresh1 print $z = $x->copy()->bdiv($y,4),"\n"; # 41150 7073b8851fccSafresh1 print $z->accuracy(),"\n"; # undef 7074b8851fccSafresh1 7075b8851fccSafresh1In addition to computing what you expected, the last example also does B<not> 7076b8851fccSafresh1"taint" the result with an accuracy or precision setting, which would 7077b8851fccSafresh1influence any further operation. 7078b8851fccSafresh1 7079b8851fccSafresh1=back 7080b8851fccSafresh1 7081b8851fccSafresh1=head1 BUGS 7082b8851fccSafresh1 7083b8851fccSafresh1Please report any bugs or feature requests to 7084b8851fccSafresh1C<bug-math-bigint at rt.cpan.org>, or through the web interface at 7085eac174f2Safresh1L<https://rt.cpan.org/Ticket/Create.html?Queue=Math-BigInt> (requires login). 7086b8851fccSafresh1We will be notified, and then you'll automatically be notified of progress on 7087b8851fccSafresh1your bug as I make changes. 7088b8851fccSafresh1 7089b8851fccSafresh1=head1 SUPPORT 7090b8851fccSafresh1 7091b8851fccSafresh1You can find documentation for this module with the perldoc command. 7092b8851fccSafresh1 7093b8851fccSafresh1 perldoc Math::BigFloat 7094b8851fccSafresh1 7095b8851fccSafresh1You can also look for information at: 7096b8851fccSafresh1 7097b8851fccSafresh1=over 4 7098b8851fccSafresh1 7099eac174f2Safresh1=item * GitHub 7100eac174f2Safresh1 7101eac174f2Safresh1L<https://github.com/pjacklam/p5-Math-BigInt> 7102eac174f2Safresh1 7103b8851fccSafresh1=item * RT: CPAN's request tracker 7104b8851fccSafresh1 7105eac174f2Safresh1L<https://rt.cpan.org/Dist/Display.html?Name=Math-BigInt> 7106b8851fccSafresh1 710756d68f1eSafresh1=item * MetaCPAN 7108b8851fccSafresh1 710956d68f1eSafresh1L<https://metacpan.org/release/Math-BigInt> 7110b8851fccSafresh1 7111b8851fccSafresh1=item * CPAN Testers Matrix 7112b8851fccSafresh1 7113b8851fccSafresh1L<http://matrix.cpantesters.org/?dist=Math-BigInt> 7114b8851fccSafresh1 7115b8851fccSafresh1=back 7116b8851fccSafresh1 7117b8851fccSafresh1=head1 LICENSE 7118b8851fccSafresh1 7119b8851fccSafresh1This program is free software; you may redistribute it and/or modify it under 7120b8851fccSafresh1the same terms as Perl itself. 7121b8851fccSafresh1 7122b8851fccSafresh1=head1 SEE ALSO 7123b8851fccSafresh1 7124*3d61058aSafresh1L<Math::BigInt> and L<Math::BigRat> as well as the backend libraries 7125*3d61058aSafresh1L<Math::BigInt::FastCalc>, L<Math::BigInt::GMP>, and L<Math::BigInt::Pari>, 7126*3d61058aSafresh1L<Math::BigInt::GMPz>, and L<Math::BigInt::BitVect>. 7127b8851fccSafresh1 7128*3d61058aSafresh1The pragmas L<bigint>, L<bigfloat>, and L<bigrat> might also be of interest. In 7129*3d61058aSafresh1addition there is the L<bignum> pragma which does upgrading and downgrading. 7130b8851fccSafresh1 7131b8851fccSafresh1=head1 AUTHORS 7132b8851fccSafresh1 7133b8851fccSafresh1=over 4 7134b8851fccSafresh1 7135b8851fccSafresh1=item * 7136b8851fccSafresh1 7137b8851fccSafresh1Mark Biggar, overloaded interface by Ilya Zakharevich, 1996-2001. 7138b8851fccSafresh1 7139b8851fccSafresh1=item * 7140b8851fccSafresh1 7141b8851fccSafresh1Completely rewritten by Tels L<http://bloodgate.com> in 2001-2008. 7142b8851fccSafresh1 7143b8851fccSafresh1=item * 7144b8851fccSafresh1 71459f11ffb7Safresh1Florian Ragwitz E<lt>flora@cpan.orgE<gt>, 2010. 7146b8851fccSafresh1 7147b8851fccSafresh1=item * 7148b8851fccSafresh1 7149eac174f2Safresh1Peter John Acklam E<lt>pjacklam@gmail.comE<gt>, 2011-. 7150b8851fccSafresh1 7151b8851fccSafresh1=back 7152b8851fccSafresh1 7153b8851fccSafresh1=cut 7154