From: Tels Date: Tue, 8 Jan 2002 03:09:34 +0000 (+0100) Subject: Math-BigInt v1.49 released X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=61f5c3f5cfd14120ba4a24ff8df561b16e9c906b;p=p5sagit%2Fp5-mst-13.2.git Math-BigInt v1.49 released p4raw-id: //depot/perl@14131 --- diff --git a/MANIFEST b/MANIFEST index deaa26a..1f53d85 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1084,10 +1084,14 @@ lib/Math/BigInt/t/bigfltpm.t See if BigFloat.pm works lib/Math/BigInt/t/bigintc.t See if BigInt/Calc.pm works lib/Math/BigInt/t/bigintpm.inc Shared tests for bigintpm.t and sub_mbi.t lib/Math/BigInt/t/bigintpm.t See if BigInt.pm works +lib/Math/BigInt/t/require.t Test if require Math::BigInt works +lib/Math/BigInt/t/use.t Test if use Math::BigInt(); works lib/Math/BigInt/t/calling.t Test calling conventions lib/Math/BigInt/t/mbimbf.t BigInt/BigFloat accuracy, precicion and fallback, round_mode +lib/Math/BigInt/t/mbimbf.inc Actual BigInt/BigFloat accuracy, precicion and fallback, round_mode tests lib/Math/BigInt/t/sub_mbf.t Empty subclass test of BigFloat lib/Math/BigInt/t/sub_mbi.t Empty subclass test of BigInt +lib/Math/BigInt/t/sub_mif.t Test A & P with subclasses using mbimbf.inc lib/Math/Complex.pm A Complex package lib/Math/Complex.t See if Math::Complex works lib/Math/Trig.pm A simple interface to complex trigonometry diff --git a/lib/Math/BigFloat.pm b/lib/Math/BigFloat.pm index a258777..92e53b3 100644 --- a/lib/Math/BigFloat.pm +++ b/lib/Math/BigFloat.pm @@ -10,20 +10,11 @@ package Math::BigFloat; -$VERSION = '1.26'; +$VERSION = '1.27'; require 5.005; use Exporter; use Math::BigInt qw/objectify/; @ISA = qw( Exporter Math::BigInt); -#@EXPORT_OK = qw( -# bcmp -# badd bmul bdiv bmod bnorm bsub -# bgcd blcm bround bfround -# bpow bnan bzero bfloor bceil -# bacmp bstr binc bdec binf -# is_odd is_even is_nan is_inf is_positive is_negative -# is_zero is_one sign -# ); use strict; use vars qw/$AUTOLOAD $accuracy $precision $div_scale $round_mode $rnd_mode/; @@ -71,10 +62,10 @@ BEGIN { tie $rnd_mode, 'Math::BigFloat'; } # valid method aliases for AUTOLOAD my %methods = map { $_ => 1 } qw / fadd fsub fmul fdiv fround ffround fsqrt fmod fstr fsstr fpow fnorm - fint facmp fcmp fzero fnan finf finc fdec - fceil ffloor frsft flsft fone + fint facmp fcmp fzero fnan finf finc fdec flog + fceil ffloor frsft flsft fone flog /; - # valid method's that need to be hand-ed up (for AUTOLOAD) + # valid method's that can be hand-ed up (for AUTOLOAD) my %hand_ups = map { $_ => 1 } qw / is_nan is_inf is_negative is_positive accuracy precision div_scale round_mode fneg fabs babs fnot @@ -94,13 +85,12 @@ sub new # _m: mantissa # sign => sign (+/-), or "NaN" - my $class = shift; + my ($class,$wanted,@r) = @_; - my $wanted = shift; # avoid numify call by not using || here - return $class->bzero() if !defined $wanted; # default to 0 - return $wanted->copy() if ref($wanted) eq $class; + # avoid numify-calls by not using || on $wanted! + return $class->bzero() if !defined $wanted; # default to 0 + return $wanted->copy() if UNIVERSAL::isa($wanted,'Math::BigFloat'); - my $round = shift; $round = 0 if !defined $round; # no rounding as default my $self = {}; bless $self, $class; # shortcut for bigints and its subclasses if ((ref($wanted)) && (ref($wanted) ne $class)) @@ -133,18 +123,15 @@ sub new else { # make integer from mantissa by adjusting exp, then convert to bigint - $self->{_e} = Math::BigInt->new("$$es$$ev"); # exponent - $self->{_m} = Math::BigInt->new("$$miv$$mfv"); # create mantissa + # undef,undef to signal MBI that we don't need no bloody rounding + $self->{_e} = Math::BigInt->new("$$es$$ev",undef,undef); # exponent + $self->{_m} = Math::BigInt->new("$$miv$$mfv",undef,undef); # create mant. # 3.123E0 = 3123E-3, and 3.123E-2 => 3123E-5 $self->{_e} -= CORE::length($$mfv) if CORE::length($$mfv) != 0; $self->{sign} = $$mis; } - #print "$wanted => $self->{sign} $self->{value}\n"; - $self->bnorm(); # first normalize - # if any of the globals is set, round to them and thus store them insid $self - $self->round($accuracy,$precision,$class->round_mode) - if defined $accuracy || defined $precision; - return $self; + # print "mbf new ",join(' ',@r),"\n"; + $self->bnorm()->round(@r); # first normalize, then round } sub bnan @@ -159,8 +146,8 @@ sub bnan $self->{_m} = Math::BigInt->bzero(); $self->{_e} = Math::BigInt->bzero(); $self->{sign} = $nan; - ($self->{_a},$self->{_p}) = @_ if @_ > 0; - return $self; + $self->{_a} = undef; $self->{_p} = undef; + $self; } sub binf @@ -177,8 +164,8 @@ sub binf $self->{_m} = Math::BigInt->bzero(); $self->{_e} = Math::BigInt->bzero(); $self->{sign} = $sign.'inf'; - ($self->{_a},$self->{_p}) = @_ if @_ > 0; - return $self; + $self->{_a} = undef; $self->{_p} = undef; + $self; } sub bone @@ -195,7 +182,13 @@ sub bone $self->{_m} = Math::BigInt->bone(); $self->{_e} = Math::BigInt->bzero(); $self->{sign} = $sign; - ($self->{_a},$self->{_p}) = @_ if @_ > 0; + if (@_ > 0) + { + $self->{_a} = $_[0] + if (defined $self->{_a} && defined $_[0] && $_[0] > $self->{_a}); + $self->{_p} = $_[1] + if (defined $self->{_p} && defined $_[1] && $_[1] < $self->{_p}); + } return $self; } @@ -211,7 +204,13 @@ sub bzero $self->{_m} = Math::BigInt->bzero(); $self->{_e} = Math::BigInt->bone(); $self->{sign} = '+'; - ($self->{_a},$self->{_p}) = @_ if @_ > 0; + if (@_ > 0) + { + $self->{_a} = $_[0] + if (defined $self->{_a} && defined $_[0] && $_[0] > $self->{_a}); + $self->{_p} = $_[1] + if (defined $self->{_p} && defined $_[1] && $_[1] < $self->{_p}); + } return $self; } @@ -243,10 +242,6 @@ sub bstr $es = $x->{_m}->bstr(); $len = CORE::length($es); if (!$x->{_e}->is_zero()) -# { -# $es = $x->{sign}.$es if $x->{sign} eq '-'; -# } -# else { if ($x->{_e}->sign() eq '-') { @@ -277,14 +272,12 @@ sub bstr # 123400 => 6, 0.1234 => 4, 0.001234 => 4 my $zeros = $x->{_a} - $cad; # cad == 0 => 12340 $zeros = $x->{_a} - $len if $cad != $len; - #print "acc padd $x->{_a} $zeros (len $len cad $cad)\n"; $es .= $dot.'0' x $zeros if $zeros > 0; } elsif ($x->{_p} || 0 < 0) { # 123400 => 6, 0.1234 => 4, 0.001234 => 6 my $zeros = -$x->{_p} + $cad; - #print "pre padd $x->{_p} $zeros (len $len cad $cad)\n"; $es .= $dot.'0' x $zeros if $zeros > 0; } return $es; @@ -477,36 +470,22 @@ sub badd my $add = $y->{_m}->copy(); if ($e < 0) { - # print "e < 0\n"; - #print "\$x->{_m}: $x->{_m} "; - #print "\$x->{_e}: $x->{_e}\n"; my $e1 = $e->copy()->babs(); $x->{_m} *= (10 ** $e1); $x->{_e} += $e; # need the sign of e - #$x->{_m} += $y->{_m}; - #print "\$x->{_m}: $x->{_m} "; - #print "\$x->{_e}: $x->{_e}\n"; } elsif ($e > 0) { - # print "e > 0\n"; - #print "\$x->{_m}: $x->{_m} \$y->{_m}: $y->{_m} \$e: $e ",ref($e),"\n"; $add *= (10 ** $e); - #$x->{_m} += $y->{_m} * (10 ** $e); - #print "\$x->{_m}: $x->{_m}\n"; } - # else: both e are same, so leave them - #print "badd $x->{sign}$x->{_m} + $y->{sign}$add\n"; - # fiddle with signs - $x->{_m}->{sign} = $x->{sign}; + # else: both e are the same, so just leave them + $x->{_m}->{sign} = $x->{sign}; # fiddle with signs $add->{sign} = $y->{sign}; - # finally do add/sub - $x->{_m} += $add; - # re-adjust signs - $x->{sign} = $x->{_m}->{sign}; - $x->{_m}->{sign} = '+'; - #$x->bnorm(); # delete trailing zeros - return $x->round($a,$p,$r,$y); + $x->{_m} += $add; # finally do add/sub + $x->{sign} = $x->{_m}->{sign}; # re-adjust signs + $x->{_m}->{sign} = '+'; # mantissa always positiv + # delete trailing zeros, then round + return $x->bnorm()->round($a,$p,$r,$y); } sub bsub @@ -590,6 +569,50 @@ sub bdec $x->badd($self->bone('-'),$a,$p,$r); # does round } +sub blog + { + my ($self,$x,$base,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(2,@_); + + # http://www.efunda.com/math/taylor_series/logarithmic.cfm?search_string=log + + # u = x-1, v = x +1 + # _ _ + # taylor: | u 1 u^3 1 u^5 | + # ln (x) = 2 | --- + - * --- + - * --- + ... | x > 0 + # |_ v 3 v 5 v _| + + return $x->bzero(@r) if $x->is_one(); + return $x->bone(@r) if $x->bcmp($base) == 0; + + my $d = $r[0] || $self->accuracy() || 40; + $d += 2; # 2 more for rounding + + my $u = $x->copy(); $u->bdec(); + my $v = $x->copy(); $v->binc(); + + $x->bdec()->bdiv($v,$d); # first term: u/v + + $u *= $u; $v *= $v; + my $below = $v->copy()->bmul($v); + my $over = $u->copy()->bmul($u); + my $factor = $self->new(3); my $two = $self->new(2); + + my $diff = $self->bone(); + my $limit = $self->new("1E-". ($d-1)); my $last; + # print "diff $diff limit $limit\n"; + while ($diff > $limit) + { + print "$x $over $below $factor\n"; + $diff = $x->copy()->bsub($last)->babs(); + print "diff $diff $limit\n"; + $last = $x->copy(); + $x += $over->copy()->bdiv($below->copy()->bmul($factor),$d); + $over *= $u; $below *= $v; $factor->badd($two); + } + $x->bmul($two); + return $x->round(@r); + } + sub blcm { # (BFLOAT or num_str, BFLOAT or num_str) return BFLOAT @@ -692,7 +715,6 @@ sub bdiv # (BFLOAT,BFLOAT) (quo,rem) or BINT (only rem) my ($self,$x,$y,$a,$p,$r) = objectify(2,@_); - # x / +-inf => 0, reminder x return wantarray ? ($x->bzero(),$x->copy()) : $x->bzero() if $y->{sign} =~ /^[+-]inf$/; @@ -719,8 +741,8 @@ sub bdiv if (scalar @params == 1) { # simulate old behaviour - $scale = $self->div_scale()+1; # at least one more for proper round $params[1] = $self->div_scale(); # and round to it as accuracy + $scale = $params[1]+4; # at least four more for proper round $params[3] = $r; # round mode by caller or undef $fallback = 1; # to clear a/p afterwards } @@ -756,7 +778,7 @@ sub bdiv # shortcut to not run trough _find_round_parameters again if (defined $params[1]) { - $x->bround($params[1],undef,$params[3]); # then round accordingly + $x->bround($params[1],$params[3]); # then round accordingly } else { @@ -795,11 +817,75 @@ sub bmod # (dividend: BFLOAT or num_str, divisor: BFLOAT or num_str) return reminder my ($self,$x,$y,$a,$p,$r) = objectify(2,@_); - return $x->bnan() if ($x->is_nan() || $y->is_nan() || $y->is_zero()); - return $x->bzero() if $y->is_one(); + if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/)) + { + my ($d,$re) = $self->SUPER::_div_inf($x,$y); + return $re->round($a,$p,$r,$y); + } + return $x->bnan() if $x->is_zero() && $y->is_zero(); + return $x if $y->is_zero(); + return $x->bnan() if $x->is_nan() || $y->is_nan(); + return $x->bzero() if $y->is_one() || $x->is_zero(); - # XXX tels: not done yet - return $x->round($a,$p,$r,$y); + # inf handling is missing here + + my $cmp = $x->bacmp($y); # equal or $x < $y? + return $x->bzero($a,$p) if $cmp == 0; # $x == $y => result 0 + + # only $y of the operands negative? + my $neg = 0; $neg = 1 if $x->{sign} ne $y->{sign}; + + $x->{sign} = $y->{sign}; # calc sign first + return $x->round($a,$p,$r) if $cmp < 0 && $neg == 0; # $x < $y => result $x + + my $ym = $y->{_m}->copy(); + + # 2e1 => 20 + $ym->blsft($y->{_e},10) if $y->{_e}->{sign} eq '+' && !$y->{_e}->is_zero(); + + # if $y has digits after dot + my $shifty = 0; # correct _e of $x by this + if ($y->{_e}->{sign} eq '-') # has digits after dot + { + # 123 % 2.5 => 1230 % 25 => 5 => 0.5 + $shifty = $y->{_e}->copy()->babs(); # no more digits after dot + $x->blsft($shifty,10); # 123 => 1230, $y->{_m} is already 25 + } + # $ym is now mantissa of $y based on exponent 0 + + my $shiftx = 0; # correct _e of $x by this + if ($x->{_e}->{sign} eq '-') # has digits after dot + { + # 123.4 % 20 => 1234 % 200 + $shiftx = $x->{_e}->copy()->babs(); # no more digits after dot + $ym->blsft($shiftx,10); + } + # 123e1 % 20 => 1230 % 20 + if ($x->{_e}->{sign} eq '+' && !$x->{_e}->is_zero()) + { + $x->{_m}->blsft($x->{_e},10); + } + $x->{_e} = Math::BigInt->bzero() unless $x->{_e}->is_zero(); + + $x->{_e}->bsub($shiftx) if $shiftx != 0; + $x->{_e}->bsub($shifty) if $shifty != 0; + + # now mantissas are equalized, exponent of $x is adjusted, so calc result + $x->{_m}->bmod($ym); + + $x->{sign} = '+' if $x->{_m}->is_zero(); # fix sign for -0 + $x->bnorm(); + + if ($neg != 0) # one of them negative => correct in place + { + my $r = $y - $x; + $x->{_m} = $r->{_m}; + $x->{_e} = $r->{_e}; + $x->{sign} = '+' if $x->{_m}->is_zero(); # fix sign for -0 + $x->bnorm(); + } + + $x->round($a,$p,$r,$y); # round and return } sub bsqrt @@ -812,16 +898,36 @@ sub bsqrt return $x if $x->{sign} eq '+inf'; # +inf return $x if $x->is_zero() || $x->is_one(); - # we need to limit the accuracy to protect against overflow (ignore $p) - my ($scale) = $x->_scale_a($self->accuracy(),$self->round_mode,$a,$r); + # we need to limit the accuracy to protect against overflow my $fallback = 0; - if (!defined $scale) + my $scale = 0; + my @params = $x->_find_round_parameters($a,$p,$r); + + # no rounding at all, so must use fallback + if (scalar @params == 1) { # simulate old behaviour - $scale = $self->div_scale()+1; # one more for proper riund - $a = $self->div_scale(); # and round to it + $params[1] = $self->div_scale(); # and round to it as accuracy + $scale = $params[1]+4; # at least four more for proper round + $params[3] = $r; # round mode by caller or undef $fallback = 1; # to clear a/p afterwards } + else + { + # the 4 below is empirical, and there might be cases where it is not + # enough... + $scale = abs($params[1] || $params[2]) + 4; # take whatever is defined + } + + # when user set globals, they would interfere with our calculation, so + # disable then and later re-enable them + no strict 'refs'; + my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef; + $abr = "$self\::precision"; my $pb = $$abr; $$abr = undef; + # we also need to disable any set A or P on $x (_find_round_parameters took + # them already into account), since these would interfere, too + delete $x->{_a}; delete $x->{_p}; + my $xas = $x->as_number(); my $gs = $xas->copy()->bsqrt(); # some guess if (($x->{_e}->{sign} ne '-') # guess can't be accurate if there are @@ -829,51 +935,67 @@ sub bsqrt && ($xas->bcmp($gs * $gs) == 0)) # guess hit the nail on the head? { # exact result - $x->{_m} = $gs; - # leave alone if _e is already right - $x->{_e} = Math::BigInt->bzero(); - return $x->bnorm()->round($a,$p,$r) + $x->{_m} = $gs; $x->{_e} = Math::BigInt->bzero(); $x->bnorm(); + # shortcut to not run trough _find_round_parameters again + if (defined $params[1]) + { + $x->bround($params[1],$params[3]); # then round accordingly + } + else + { + $x->bfround($params[2],$params[3]); # then round accordingly + } + if ($fallback) + { + # clear a/p after round, since user did not request it + $x->{_a} = undef; $x->{_p} = undef; + } + return $x; } - $gs = $self->new( $gs ); + $gs = $self->new( $gs ); # BigInt to BigFloat my $lx = $x->{_m}->length(); $scale = $lx if $scale < $lx; my $e = $self->new("1E-$scale"); # make test variable return $x->bnan() if $e->sign() eq 'NaN'; - # start with some reasonable guess -# $lx = $lx+$x->{_e}; -# $lx = $lx / 2; -# $lx = 1 if $lx < 1; - # my $gs = Math::BigFloat->new("1E$lx"); - -# print "first guess: $gs (x $x) scale $scale\n"; -# # use BigInt:sqrt as reasonabe guess -# print "second guess: $gs (x $x) scale $scale\n"; - - my $diff = $e; my $y = $x->copy(); my $two = $self->new(2); + my $diff = $e; # promote BigInts and it's subclasses (except when already a BigFloat) $y = $self->new($y) unless $y->isa('Math::BigFloat'); + my $rem; # my $steps = 0; while ($diff >= $e) { - # return $x->bnan() if $gs->is_zero(); +# return $x->bnan() if $gs->is_zero(); - $x = $y->copy()->bdiv($gs,$scale)->badd($gs)->bdiv($two,$scale); - $diff = $x->copy()->bsub($gs)->babs(); - $gs = $x->copy(); + $rem = $y->copy()->bdiv($gs,$scale)->badd($gs)->bdiv($two,$scale); + $diff = $rem->copy()->bsub($gs)->babs(); + $gs = $rem->copy(); # $steps++; } # print "steps $steps\n"; - $x->round($a,$p,$r); + # copy over to modify $x + $x->{_m} = $rem->{_m}; $x->{_e} = $rem->{_e}; + + # shortcut to not run trough _find_round_parameters again + if (defined $params[1]) + { + $x->bround($params[1],$params[3]); # then round accordingly + } + else + { + $x->bfround($params[2],$params[3]); # then round accordingly + } if ($fallback) { # clear a/p after round, since user did not request it $x->{_a} = undef; $x->{_p} = undef; } + # restore globals + ${"$self\::accuracy"} = $ab; ${"$self\::precision"} = $pb; $x; } @@ -931,7 +1053,12 @@ sub bfround return $x if !defined $scale; # no-op # never round a 0, +-inf, NaN - return $x if $x->{sign} !~ /^[+-]$/ || $x->is_zero(); + if ($x->is_zero()) + { + $x->{_p} = $scale if !defined $x->{_p} || $x->{_p} < $scale; # -3 < -2 + return $x; + } + return $x if $x->{sign} !~ /^[+-]$/; # print "MBF bfround $x to scale $scale mode $mode\n"; # don't round if x already has lower precision @@ -1028,33 +1155,33 @@ sub bround my ($scale,$mode) = $x->_scale_a($self->accuracy(),$self->round_mode(),@_); return $x if !defined $scale; # no-op - + return $x if $x->modify('bround'); - + # scale is now either $x->{_a}, $accuracy, or the user parameter # test whether $x already has lower accuracy, do nothing in this case # but do round if the accuracy is the same, since a math operation might # want to round a number with A=5 to 5 digits afterwards again return $x if defined $_[0] && defined $x->{_a} && $x->{_a} < $_[0]; - # print "bround $scale $mode\n"; - # 0 => return all digits, scale < 0 makes no sense - return $x if ($scale <= 0); - # never round a 0, +-inf, NaN - return $x if $x->{sign} !~ /^[+-]$/ || $x->is_zero(); + # scale < 0 makes no sense + # never round a +-inf, NaN + return $x if ($scale < 0) || $x->{sign} !~ /^[+-]$/; - # if $e longer than $m, we have 0.0000xxxyyy style number, and must - # subtract the delta from scale, to simulate keeping the zeros - # -5 +5 => 1; -10 +5 => -4 - my $delta = $x->{_e} + $x->{_m}->length() + 1; - - # if we should keep more digits than the mantissa has, do nothing - return $x if $x->{_m}->length() <= $scale; + # 1: $scale == 0 => keep all digits + # 2: never round a 0 + # 3: if we should keep more digits than the mantissa has, do nothing + if ($scale == 0 || $x->is_zero() || $x->{_m}->length() <= $scale) + { + $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale; + return $x; + } # pass sign to bround for '+inf' and '-inf' rounding modes $x->{_m}->{sign} = $x->{sign}; $x->{_m}->bround($scale,$mode); # round mantissa $x->{_m}->{sign} = '+'; # fix sign back + # $x->{_m}->{_a} = undef; $x->{_m}->{_p} = undef; $x->{_a} = $scale; # remember rounding $x->{_p} = undef; # and clear P $x->bnorm(); # del trailing zeros gen. by bround() @@ -1076,7 +1203,7 @@ sub bfloor $x->{_e}->bzero(); $x-- if $x->{sign} eq '-'; } - return $x->round($a,$p,$r); + $x->round($a,$p,$r); } sub bceil @@ -1094,7 +1221,7 @@ sub bceil $x->{_e}->bzero(); $x++ if $x->{sign} eq '+'; } - return $x->round($a,$p,$r); + $x->round($a,$p,$r); } sub brsft @@ -1186,7 +1313,7 @@ sub mantissa my $m = $x->{_m}->copy(); # faster than going via bstr() $m->bneg() if $x->{sign} eq '-'; - return $m; + $m; } sub parts @@ -1247,8 +1374,8 @@ sub bnorm # 'forget' that mantissa was rounded via MBI::bround() in MBF's bfround() $x->{_m}->{_a} = undef; $x->{_e}->{_a} = undef; $x->{_m}->{_p} = undef; $x->{_e}->{_p} = undef; - return $x; # MBI bnorm is no-op, so dont call it - } + $x; # MBI bnorm is no-op, so dont call it + } ############################################################################## # internal calculation routines @@ -1275,7 +1402,7 @@ sub as_number $z->blsft($x->{_e},10); } $z->{sign} = $x->{sign}; - return $z; + $z; } sub length @@ -1293,7 +1420,7 @@ sub length $t = $x->{_e}->copy()->babs() if $x->{_e}->sign() eq '-'; return ($len,$t); } - return $len; + $len; } 1; @@ -1351,6 +1478,9 @@ Math::BigFloat - Arbitrary size floating point math package $x->brsft($y); # right shift # return (quo,rem) or quo if scalar + $x->blog($base); # logarithm of $x, base defaults to e + # (other bases than e not supported yet) + $x->band($y); # bit-wise and $x->bior($y); # bit-wise inclusive or $x->bxor($y); # bit-wise exclusive or diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm index 354bc71..516406b 100644 --- a/lib/Math/BigInt.pm +++ b/lib/Math/BigInt.pm @@ -14,21 +14,10 @@ package Math::BigInt; my $class = "Math::BigInt"; require 5.005; -$VERSION = '1.48'; +$VERSION = '1.49'; use Exporter; @ISA = qw( Exporter ); -# no longer export stuff (it doesn't work with subclasses anyway) -# bneg babs bcmp badd bmul bdiv bmod bnorm bsub -# bgcd blcm bround -# blsft brsft band bior bxor bnot bpow bnan bzero -# bacmp bstr bsstr binc bdec binf bfloor bceil -# is_odd is_even is_zero is_one is_nan is_inf sign -# is_positive is_negative -# length as_number -@EXPORT_OK = qw( - objectify _swap - bgcd blcm - ); +@EXPORT_OK = qw( objectify _swap bgcd blcm); use vars qw/$round_mode $accuracy $precision $div_scale $rnd_mode/; use strict; @@ -78,6 +67,7 @@ use overload $_[1] cmp $_[0]->bstr() : $_[0]->bstr() cmp $_[1] }, +'log' => sub { $_[0]->copy()->blog(); }, 'int' => sub { $_[0]->copy(); }, 'neg' => sub { $_[0]->copy()->bneg(); }, 'abs' => sub { $_[0]->copy()->babs(); }, @@ -123,6 +113,7 @@ my $NaNOK=1; # are NaNs ok? my $nan = 'NaN'; # constants for easier life my $CALC = 'Math::BigInt::Calc'; # module to do low level math +my $IMPORT = 0; # did import() yet? sub _core_lib () { return $CALC; } # for test suite $round_mode = 'even'; # one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc' @@ -319,7 +310,7 @@ sub copy } else # normal ref { - my $xk = $x->{$k}; + my $xk = $x->{$k}; if ($xk->can('copy')) { $self->{$k} = $xk->copy(); @@ -342,12 +333,14 @@ sub new # cause costly overloaded code to be called. The only allowed ops are # ref() and defined. - my $class = shift; + my ($class,$wanted,$a,$p,$r) = @_; - my $wanted = shift; # avoid numify call by not using || here - return $class->bzero() if !defined $wanted; # default to 0 - return $class->copy($wanted) if ref($wanted); + # avoid numify-calls by not using || on $wanted! + return $class->bzero($a,$p) if !defined $wanted; # default to 0 + return $class->copy($wanted,$a,$p,$r) if ref($wanted); + $class->import() if $IMPORT == 0; # make require work + my $self = {}; bless $self, $class; # handle '+inf', '-inf' first if ($wanted =~ /^[+-]?inf$/) @@ -415,8 +408,9 @@ sub new $self->{sign} = '+' if $$miv eq '0'; # normalize -0 => +0 $self->{value} = $CALC->_new($miv) if $self->{sign} =~ /^[+-]$/; # if any of the globals is set, use them to round and store them inside $self - $self->round($accuracy,$precision,$round_mode) - if defined $accuracy || defined $precision; + # do not round for new($x,undef,undef) since that is used by MBF to signal + # no rounding + $self->round($a,$p,$r) unless @_ == 4 && !defined $a && !defined $p; return $self; } @@ -429,6 +423,7 @@ sub bnan { my $c = $self; $self = {}; bless $self, $c; } + $self->import() if $IMPORT == 0; # make require work return if $self->modify('bnan'); $self->{value} = $CALC->_zero(); $self->{sign} = $nan; @@ -447,6 +442,7 @@ sub binf { my $c = $self; $self = {}; bless $self, $c; } + $self->import() if $IMPORT == 0; # make require work return if $self->modify('binf'); $self->{value} = $CALC->_zero(); $self->{sign} = $sign.'inf'; @@ -464,10 +460,17 @@ sub bzero { my $c = $self; $self = {}; bless $self, $c; } + $self->import() if $IMPORT == 0; # make require work return if $self->modify('bzero'); $self->{value} = $CALC->_zero(); $self->{sign} = '+'; - ($self->{_a},$self->{_p}) = @_; # take over requested rounding + if (@_ > 0) + { + $self->{_a} = $_[0] + if (defined $self->{_a} && defined $_[0] && $_[0] > $self->{_a}); + $self->{_p} = $_[1] + if (defined $self->{_p} && defined $_[1] && $_[1] < $self->{_p}); + } return $self; } @@ -483,10 +486,17 @@ sub bone { my $c = $self; $self = {}; bless $self, $c; } + $self->import() if $IMPORT == 0; # make require work return if $self->modify('bone'); $self->{value} = $CALC->_one(); $self->{sign} = $sign; - ($self->{_a},$self->{_p}) = @_; # take over requested rounding + if (@_ > 0) + { + $self->{_a} = $_[0] + if (defined $self->{_a} && defined $_[0] && $_[0] > $self->{_a}); + $self->{_p} = $_[1] + if (defined $self->{_p} && defined $_[1] && $_[1] < $self->{_p}); + } return $self; } @@ -553,84 +563,119 @@ sub _find_round_parameters { # After any operation or when calling round(), the result is rounded by # regarding the A & P from arguments, local parameters, or globals. - # The result's A or P are set by the rounding, but not inspected beforehand - # (aka only the arguments enter into it). This works because the given - # 'first' argument is both the result and true first argument with unchanged - # A and P settings. - # This does not yet handle $x with A, and $y with P (which should be an - # error). + + # This procedure finds the round parameters, but it is for speed reasons + # duplicated in round. Otherwise, it is tested by the testsuite and used + # by fdiv(). + my ($self,$a,$p,$r,@args) = @_; # $a accuracy, if given by caller # $p precision, if given by caller # $r round_mode, if given by caller # @args all 'other' arguments (0 for unary, 1 for binary ops) - # $self = new($self) unless ref($self); # if not object, make one - # leave bigfloat parts alone return ($self) if exists $self->{_f} && $self->{_f} & MB_NEVER_ROUND != 0; - unshift @args,$self; # add 'first' argument my $c = ref($self); # find out class of argument(s) no strict 'refs'; # now pick $a or $p, but only if we have got "arguments" - if ((!defined $a) && (!defined $p) && (@args > 0)) + if (!defined $a) { - foreach (@args) + foreach ($self,@args) { # take the defined one, or if both defined, the one that is smaller $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a); } - if (!defined $a) # if it still is not defined, take p - { - foreach (@args) - { - # take the defined one, or if both defined, the one that is bigger - # -2 > -3, and 3 > 2 - $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p); - } - # if none defined, use globals (#2) - if (!defined $p) - { - my $z = "$c\::accuracy"; my $a = $$z; - if (!defined $a) - { - $z = "$c\::precision"; $p = $$z; - } - } - } # endif !$a - } # endif !$a || !$P && args > 0 - my @params = ($self); - if (defined $a || defined $p) + } + if (!defined $p) { - $r = $r || ${"$c\::round_mode"}; - die "Unknown round mode '$r'" - if $r !~ /^(even|odd|\+inf|\-inf|zero|trunc)$/; - push @params, ($a,$p,$r); + # even if $a is defined, take $p, to signal error for both defined + foreach ($self,@args) + { + # take the defined one, or if both defined, the one that is bigger + # -2 > -3, and 3 > 2 + $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p); + } } - return @params; + # if still none defined, use globals (#2) + $a = ${"$c\::accuracy"} unless defined $a; + $p = ${"$c\::precision"} unless defined $p; + + # no rounding today? + return ($self) unless defined $a || defined $p; # early out + + # set A and set P is an fatal error + return ($self->bnan()) if defined $a && defined $p; + + $r = ${"$c\::round_mode"} unless defined $r; + die "Unknown round mode '$r'" if $r !~ /^(even|odd|\+inf|\-inf|zero|trunc)$/; + + return ($self,$a,$p,$r); } sub round { - # round $self according to given parameters, or given second argument's + # Round $self according to given parameters, or given second argument's # parameters or global defaults - my $self = shift; - - my @params = $self->_find_round_parameters(@_); - return $self->bnorm() if @params == 1; # no-op - # now round, by calling fround or ffround: - if (defined $params[1]) + # for speed reasons, _find_round_parameters is embeded here: + + my ($self,$a,$p,$r,@args) = @_; + # $a accuracy, if given by caller + # $p precision, if given by caller + # $r round_mode, if given by caller + # @args all 'other' arguments (0 for unary, 1 for binary ops) + + # leave bigfloat parts alone + return ($self) if exists $self->{_f} && $self->{_f} & MB_NEVER_ROUND != 0; + + my $c = ref($self); # find out class of argument(s) + no strict 'refs'; + + # now pick $a or $p, but only if we have got "arguments" + if (!defined $a) { - $self->bround($params[1],$params[3]); + foreach ($self,@args) + { + # take the defined one, or if both defined, the one that is smaller + $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a); + } } - else + if (!defined $p) + { + # even if $a is defined, take $p, to signal error for both defined + foreach ($self,@args) + { + # take the defined one, or if both defined, the one that is bigger + # -2 > -3, and 3 > 2 + $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p); + } + } + # if still none defined, use globals (#2) + $a = ${"$c\::accuracy"} unless defined $a; + $p = ${"$c\::precision"} unless defined $p; + + # no rounding today? + return $self unless defined $a || defined $p; # early out + + # set A and set P is an fatal error + return $self->bnan() if defined $a && defined $p; + + $r = ${"$c\::round_mode"} unless defined $r; + die "Unknown round mode '$r'" if $r !~ /^(even|odd|\+inf|\-inf|zero|trunc)$/; + + # now round, by calling either fround or ffround: + if (defined $a) + { + $self->bround($a,$r) if !defined $self->{_a} || $self->{_a} >= $a; + } + else # both can't be undefined due to early out { - $self->bfround($params[2],$params[3]); + $self->bfround($p,$r) if !defined $self->{_p} || $self->{_p} <= $p; } - return $self->bnorm(); # after round, normalize + $self->bnorm(); # after round, normalize } sub bnorm @@ -728,10 +773,11 @@ sub badd { # add second arg (BINT or string) to first (BINT) (modifies first) # return result as BINT - my ($self,$x,$y,$a,$p,$r) = objectify(2,@_); + my ($self,$x,$y,@r) = objectify(2,@_); return $x if $x->modify('badd'); + $r[3] = $y; # no push! # inf and NaN handling if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/)) { @@ -741,7 +787,7 @@ sub badd if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/)) { # + and + => +, - and - => -, + and - => 0, - and + => 0 - return $x->bzero() if $x->{sign} ne $y->{sign}; + return $x->bzero(@r) if $x->{sign} ne $y->{sign}; return $x; } # +-inf + something => +inf @@ -750,15 +796,14 @@ sub badd return $x; } - my @bn = ($a,$p,$r,$y); # make array for round calls # speed: no add for 0+y or x+0 - return $x->round(@bn) if $y->is_zero(); # x+0 + return $x->round(@r) if $y->is_zero(); # x+0 if ($x->is_zero()) # 0+y { # make copy, clobbering up x $x->{value} = $CALC->_copy($y->{value}); $x->{sign} = $y->{sign} || $nan; - return $x->round(@bn); + return $x->round(@r); } my ($sx, $sy) = ( $x->{sign}, $y->{sign} ); # get signs @@ -791,7 +836,7 @@ sub badd $x->{sign} = $sx; } } - return $x->round(@bn); + $x->round(@r); } sub bsub @@ -808,7 +853,7 @@ sub bsub $x->badd($y,$a,$p,$r); # badd does not leave internal zeros $y->{sign} =~ tr/+\-/-+/; # refix $y (does nothing for NaN) } - $x; # already rounded by badd() + $x; # already rounded by badd() or no round necc. } sub binc @@ -829,7 +874,7 @@ sub binc return $x->round($a,$p,$r); } # inf, nan handling etc - $x->badd($self->__one(),$a,$p,$r); # does round + $x->badd($self->__one(),$a,$p,$r); # badd does round } sub bdec @@ -854,9 +899,17 @@ sub bdec return $x->round($a,$p,$r); } # inf, nan handling etc - $x->badd($self->__one('-'),$a,$p,$r); # does round + $x->badd($self->__one('-'),$a,$p,$r); # badd does round } +sub blog + { + # not implemented yet + my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_); + + return $x->bnan(); + } + sub blcm { # (BINT or num_str, BINT or num_str) return BINT @@ -915,8 +968,7 @@ sub bnot my ($self,$x,$a,$p,$r) = ref($_[0]) ? (undef,@_) : objectify(1,@_); return $x if $x->modify('bnot'); - $x->bneg(); $x->bdec(); # was: bsub(-1,$x);, time it someday - return $x->round($a,$p,$r); + $x->bneg()->bdec(); # bdec already does round } sub is_zero @@ -1015,13 +1067,16 @@ sub bmul { # multiply two numbers -- stolen from Knuth Vol 2 pg 233 # (BINT or num_str, BINT or num_str) return BINT - my ($self,$x,$y,$a,$p,$r) = objectify(2,@_); + my ($self,$x,$y,@r) = objectify(2,@_); return $x if $x->modify('bmul'); + + $r[3] = $y; # no push here + return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan)); # handle result = 0 - return $x if $x->is_zero(); - return $x->bzero() if $y->is_zero(); + return $x->round(@r) if $x->is_zero(); + return $x->bzero()->round(@r) if $y->is_zero(); # inf handling if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/)) { @@ -1036,7 +1091,7 @@ sub bmul $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; # +1 * +1 or -1 * -1 => + $x->{value} = $CALC->_mul($x->{value},$y->{value}); # do actual math - return $x->round($a,$p,$r,$y); + return $x->round(@r); } sub _div_inf @@ -1095,30 +1150,33 @@ sub bdiv { # (dividend: BINT or num_str, divisor: BINT or num_str) return # (BINT,BINT) (quo,rem) or BINT (only rem) - my ($self,$x,$y,$a,$p,$r) = objectify(2,@_); + my ($self,$x,$y,@r) = objectify(2,@_); return $x if $x->modify('bdiv'); return $self->_div_inf($x,$y) if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero()); + $r[3] = $y; # no push! + # 0 / something - return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero(); + return + wantarray ? ($x->round(@r),$self->bzero(@r)):$x->round(@r) if $x->is_zero(); # Is $x in the interval [0, $y) ? my $cmp = $CALC->_acmp($x->{value},$y->{value}); if (($cmp < 0) and ($x->{sign} eq $y->{sign})) { - return $x->bzero() unless wantarray; + return $x->bzero()->round(@r) unless wantarray; my $t = $x->copy(); # make copy first, because $x->bzero() clobbers $x - return ($x->bzero(),$t); + return ($x->bzero()->round(@r),$t); } elsif ($cmp == 0) { # shortcut, both are the same, so set to +/- 1 $x->__one( ($x->{sign} ne $y->{sign} ? '-' : '+') ); return $x unless wantarray; - return ($x,$self->bzero()); + return ($x->round(@r),$self->bzero(@r)); } # calc new sign and in case $y == +/- 1, return $x @@ -1127,7 +1185,7 @@ sub bdiv # check for / +-1 (cant use $y->is_one due to '-' if ($CALC->_is_one($y->{value})) { - return wantarray ? ($x,$self->bzero()) : $x; + return wantarray ? ($x->round(@r),$self->bzero(@r)) : $x->round(@r); } my $rem; @@ -1136,7 +1194,7 @@ sub bdiv my $rem = $self->bzero(); ($x->{value},$rem->{value}) = $CALC->_div($x->{value},$y->{value}); $x->{sign} = '+' if $CALC->_is_zero($x->{value}); - $x->round($a,$p,$r,$y); + $x->round(@r); if (! $CALC->_is_zero($rem->{value})) { $rem->{sign} = $y->{sign}; @@ -1146,26 +1204,28 @@ sub bdiv { $rem->{sign} = '+'; # dont leave -0 } - $rem->round($a,$p,$r,$x,$y); + $rem->round(@r); return ($x,$rem); } $x->{value} = $CALC->_div($x->{value},$y->{value}); $x->{sign} = '+' if $CALC->_is_zero($x->{value}); - $x->round($a,$p,$r,$y); + $x->round(@r); + $x; } sub bmod { # modulus (or remainder) # (BINT or num_str, BINT or num_str) return BINT - my ($self,$x,$y,$a,$p,$r) = objectify(2,@_); - + my ($self,$x,$y,@r) = objectify(2,@_); + return $x if $x->modify('bmod'); + $r[3] = $y; # no push! if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero()) { my ($d,$r) = $self->_div_inf($x,$y); - return $r; + return $r->round(@r); } if ($CALC->can('_mod')) @@ -1182,12 +1242,9 @@ sub bmod { $x->{sign} = '+'; # dont leave -0 } + return $x->round(@r); } - else - { - $x = (&bdiv($self,$x,$y))[1]; # slow way - } - $x->round($a,$p,$r); + $x = (&bdiv($self,$x,$y,@r))[1]; # slow way (also rounds) } sub bpow @@ -1195,29 +1252,30 @@ sub bpow # (BINT or num_str, BINT or num_str) return BINT # compute power of two numbers -- stolen from Knuth Vol 2 pg 233 # modifies first argument - my ($self,$x,$y,$a,$p,$r) = objectify(2,@_); + my ($self,$x,$y,@r) = objectify(2,@_); return $x if $x->modify('bpow'); + $r[3] = $y; # no push! return $x if $x->{sign} =~ /^[+-]inf$/; # -inf/+inf ** x return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan; - return $x->__one() if $y->is_zero(); - return $x if $x->is_one() || $y->is_one(); + return $x->bone(@r) if $y->is_zero(); + return $x->round(@r) if $x->is_one() || $y->is_one(); if ($x->{sign} eq '-' && $CALC->_is_one($x->{value})) { # if $x == -1 and odd/even y => +1/-1 - return $y->is_odd() ? $x : $x->babs(); + return $y->is_odd() ? $x->round(@r) : $x->babs()->round(@r); # my Casio FX-5500L has a bug here: -1 ** 2 is -1, but -1 * -1 is 1; } # 1 ** -y => 1 / (1 ** |y|) # so do test for negative $y after above's clause return $x->bnan() if $y->{sign} eq '-'; - return $x if $x->is_zero(); # 0**y => 0 (if not y <= 0) + return $x->round(@r) if $x->is_zero(); # 0**y => 0 (if not y <= 0) if ($CALC->can('_pow')) { $x->{value} = $CALC->_pow($x->{value},$y->{value}); - return $x->round($a,$p,$r); + return $x->round(@r); } # based on the assumption that shifting in base 10 is fast, and that mul @@ -1247,7 +1305,7 @@ sub bpow $x->bmul($x); } $x->bmul($pow2) unless $pow2->is_one(); - return $x->round($a,$p,$r); + return $x->round(@r); } sub blsft @@ -1447,7 +1505,6 @@ sub _trailing_zeros # if not: since we do not know underlying internal representation: my $es = "$x"; $es =~ /([0]*)$/; - return 0 if !defined $1; # no zeros return CORE::length("$1"); # as string, not as +0! } @@ -1541,6 +1598,7 @@ sub bfround # no-op for BigInts if $n <= 0 if ($scale <= 0) { + $x->{_a} = undef; # clear an eventual set A $x->{_p} = $scale; return $x; } @@ -1560,7 +1618,6 @@ sub _scan_for_nonzero return 0 if $len == 1; # '5' is trailed by invisible zeros my $follow = $pad - 1; return 0 if $follow > $len || $follow < 1; - #print "checking $x $r\n"; # since we do not know underlying represention of $x, use decimal string #my $r = substr ($$xs,-$follow); @@ -1583,20 +1640,24 @@ sub bround # no-op for $n == 0 # and overwrite the rest with 0's, return normalized number # do not return $x->bnorm(), but $x + my $x = shift; $x = $class->new($x) unless ref $x; my ($scale,$mode) = $x->_scale_a($x->accuracy(),$x->round_mode(),@_); - return $x if !defined $scale; # no-op + return $x if !defined $scale; # no-op - # print "MBI round: $x to $scale $mode\n"; - return $x if $x->{sign} !~ /^[+-]$/ || $x->is_zero() || $scale == 0; + if ($x->is_zero() || $scale == 0) + { + $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale; # 3 > 2 + return $x; + } + return $x if $x->{sign} !~ /^[+-]$/; # inf, NaN # we have fewer digits than we want to scale to my $len = $x->length(); - # print "$scale $len\n"; # scale < 0, but > -len (not >=!) if (($scale < 0 && $scale < -$len-1) || ($scale >= $len)) { - $x->{_a} = $scale if !defined $x->{_a}; # if not yet defined overwrite + $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale; # 3 > 2 return $x; } @@ -1606,19 +1667,15 @@ sub bround $pad = abs($scale-1) if $scale < 0; # do not use digit(), it is costly for binary => decimal - #$digit_round = '0'; $digit_round = $x->digit($pad) if $pad < $len; - #$digit_after = '0'; $digit_after = $x->digit($pad-1) if $pad > 0; my $xs = $CALC->_str($x->{value}); my $pl = -$pad-1; - # print "pad $pad pl $pl scale $scale len $len\n"; # pad: 123: 0 => -1, at 1 => -2, at 2 => -3, at 3 => -4 # pad+1: 123: 0 => 0, at 1 => -1, at 2 => -2, at 3 => -3 $digit_round = '0'; $digit_round = substr($$xs,$pl,1) if $pad <= $len; $pl++; $pl ++ if $pad >= $len; - $digit_after = '0'; $digit_after = substr($$xs,$pl,1) - if $pad > 0; + $digit_after = '0'; $digit_after = substr($$xs,$pl,1) if $pad > 0; # print "$pad $pl $$xs dr $digit_round da $digit_after\n"; @@ -1638,56 +1695,56 @@ sub bround ($mode eq '-inf') && ($x->{sign} eq '+') || ($mode eq 'zero') # round down if zero, sign adjusted below ); - # allow rounding one place left of mantissa - #print "$pad $len $scale\n"; - # this is triggering warnings, and buggy for $scale < 0 - #if (-$scale != $len) - { - # old code, depend on internal representation - # split mantissa at $pad and then pad with zeros - #my $s5 = int($pad / 5); - #my $i = 0; - #while ($i < $s5) - # { - # $x->{value}->[$i++] = 0; # replace with 5 x 0 - # } - #$x->{value}->[$s5] = '00000'.$x->{value}->[$s5]; # pad with 0 - #my $rem = $pad % 5; # so much left over - #if ($rem > 0) - # { - # #print "remainder $rem\n"; - ## #print "elem $x->{value}->[$s5]\n"; - # substr($x->{value}->[$s5],-$rem,$rem) = '0' x $rem; # stamp w/ '0' - # } - #$x->{value}->[$s5] = int ($x->{value}->[$s5]); # str '05' => int '5' - #print ${$CALC->_str($pad->{value})}," $len\n"; - if (($pad > 0) && ($pad <= $len)) - { - substr($$xs,-$pad,$pad) = '0' x $pad; - $x->{value} = $CALC->_new($xs); # put back in - } - elsif ($pad > $len) - { - $x->bzero(); # round to '0' - } - # print "res $pad $len $x $$xs\n"; + my $put_back = 0; # not yet modified + + # old code, depend on internal representation + # split mantissa at $pad and then pad with zeros + #my $s5 = int($pad / 5); + #my $i = 0; + #while ($i < $s5) + # { + # $x->{value}->[$i++] = 0; # replace with 5 x 0 + # } + #$x->{value}->[$s5] = '00000'.$x->{value}->[$s5]; # pad with 0 + #my $rem = $pad % 5; # so much left over + #if ($rem > 0) + # { + # #print "remainder $rem\n"; + ## #print "elem $x->{value}->[$s5]\n"; + # substr($x->{value}->[$s5],-$rem,$rem) = '0' x $rem; # stamp w/ '0' + # } + #$x->{value}->[$s5] = int ($x->{value}->[$s5]); # str '05' => int '5' + #print ${$CALC->_str($pad->{value})}," $len\n"; + + if (($pad > 0) && ($pad <= $len)) + { + substr($$xs,-$pad,$pad) = '0' x $pad; + $put_back = 1; } - # move this later on after the inc of the string - #$x->{value} = $CALC->_new($xs); # put back in + elsif ($pad > $len) + { + $x->bzero(); # round to '0' + } + if ($round_up) # what gave test above? { - #print " $pad => "; - $pad = $len if $scale < 0; # tlr: whack 0.51=>1.0 - # modify $x in place, undef, undef to avoid rounding - # str creation much faster than 10 ** something - #print " $pad, $x => "; - $x->badd( Math::BigInt->new($x->{sign}.'1'.'0'x$pad) ); - #print "$x\n"; - # increment string in place, to avoid dec=>hex for the '1000...000' - # $xs ...blah foo + $put_back = 1; + $pad = $len, $$xs = '0'x$pad if $scale < 0; # tlr: whack 0.51=>1.0 + + # we modify directly the string variant instead of creating a number and + # adding it + my $c = 0; $pad ++; # for $pad == $len case + while ($pad <= $len) + { + $c = substr($$xs,-$pad,1) + 1; $c = '0' if $c eq '10'; + substr($$xs,-$pad,1) = $c; $pad++; + last if $c != 0; # no overflow => early out + } + $$xs = '1'.$$xs if $c == 0; + + # $x->badd( Math::BigInt->new($x->{sign}.'1'. '0' x $pad) ); } - # to here: - #$x->{value} = $CALC->_new($xs); # put back in + $x->{value} = $CALC->_new($xs) if $put_back == 1; # put back in $x->{_a} = $scale if $scale >= 0; if ($scale < 0) @@ -1789,12 +1846,8 @@ sub objectify #return (ref($_[1]),$_[1],$_[2]) if (@_ == 3) && ($_[0]||0 == 2) # && ref($_[1]) && ref($_[2]); -# print "obj '",join ("' '", @_),"'\n"; - my $count = abs(shift || 0); -# print "MBI ",caller(),"\n"; - my @a; # resulting array if (ref $_[0]) { @@ -1805,10 +1858,8 @@ sub objectify { # nope, got 1,2 (Class->xxx(1) => Class,1 and not supported) $a[0] = $class; - #print "@_\n"; sleep(1); $a[0] = shift if $_[0] =~ /^[A-Z].*::/; # classname as first? } - #print caller(),"\n"; # print "Now in objectify, my class is today $a[0]\n"; my $k; if ($count == 0) @@ -1832,10 +1883,8 @@ sub objectify { while ($count > 0) { - #print "$count\n"; $count--; $k = shift; -# print "$k (",ref($k),") => \n"; if (!ref($k)) { $k = $a[0]->new($k); @@ -1845,19 +1894,10 @@ sub objectify # foreign object, try to convert to integer $k->can('as_number') ? $k = $k->as_number() : $k = $a[0]->new($k); } - # print "$k (",ref($k),")\n"; push @a,$k; } push @a,@_; # return other params, too } - #my $i = 0; - #foreach (@a) - # { - # print "o $i $a[0]\n" if $i == 0; - # print "o $i ",ref($_),"\n" if $i != 0; $i++; - # } - #print "objectify done: would return ",scalar @a," values\n"; - #print caller(1),"\n" unless wantarray; die "$class objectify needs list context" unless wantarray; @a; } @@ -1865,7 +1905,8 @@ sub objectify sub import { my $self = shift; - #print "import $self @_\n"; + + $IMPORT++; my @a = @_; my $l = scalar @_; my $j = 0; for ( my $i = 0; $i < $l ; $i++,$j++ ) { @@ -1878,7 +1919,7 @@ sub import elsif ($_[$i] =~ /^lib$/i) { # this causes a different low lib to take care... - $CALC = $_[$i+1] || $CALC; + $CALC = $_[$i+1] || ''; my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..." splice @a, $j, $s; $j -= $s; } @@ -1891,11 +1932,12 @@ sub import # try to load core math lib my @c = split /\s*,\s*/,$CALC; push @c,'Calc'; # if all fail, try this + $CALC = ''; # signal error foreach my $lib (@c) { $lib = 'Math::BigInt::'.$lib if $lib !~ /^Math::BigInt/i; $lib =~ s/\.pm$//; - if ($] < 5.6) + if ($] < 5.006) { # Perl < 5.6.0 dies with "out of memory!" when eval() and ':constant' is # used in the same script, or eval inside import(). @@ -1905,10 +1947,11 @@ sub import } else { - eval "use $lib @c;"; + eval "use $lib qw/@c/;"; } $CALC = $lib, last if $@ eq ''; # no error in loading lib? } + die "Couldn't load any math lib, not even the default" if $CALC eq ''; } sub __from_hex @@ -1944,7 +1987,6 @@ sub __from_hex $val = substr($$hs,$i,4); $val =~ s/^[+-]?0x// if $len == 0; # for last part only because $val = hex($val); # hex does not like wrong chars - # print "$val ",substr($$hs,$i,4),"\n"; $i -= 4; $len --; $x += $mul * $val if $val != 0; $mul *= $x65536 if $len >= 0; # skip last mul @@ -2034,14 +2076,12 @@ sub _split my ($m,$e) = split /[Ee]/,$$x; $e = '0' if !defined $e || $e eq ""; - # print "m '$m' e '$e'\n"; # sign,value for exponent,mantint,mantfrac my ($es,$ev,$mis,$miv,$mfv); # valid exponent? if ($e =~ /^([+-]?)0*(\d+)$/) # strip leading zeros { $es = $1; $ev = $2; - #print "'$m' '$e' e: $es $ev "; # valid mantissa? return if $m eq '.' || $m eq ''; my ($mi,$mf) = split /\./,$m; @@ -2051,11 +2091,8 @@ sub _split if ($mi =~ /^([+-]?)0*(\d+)$/) # strip leading zeros { $mis = $1||'+'; $miv = $2; - # print "$mis $miv"; - # valid, existing fraction part of mantissa? return unless ($mf =~ /^(\d*?)0*$/); # strip trailing zeros $mfv = $1; - #print " split: $mis $miv . $mfv E $es $ev\n"; return (\$mis,\$miv,\$mfv,\$es,\$ev); } } @@ -2089,11 +2126,11 @@ sub as_hex else { my $x1 = $x->copy()->babs(); my $xr; - my $x100 = Math::BigInt->new (0x100); + my $x10000 = Math::BigInt->new (0x10000); while (!$x1->is_zero()) { - ($x1, $xr) = bdiv($x1,$x100); - $es .= unpack('h2',pack('C',$xr->numify())); + ($x1, $xr) = bdiv($x1,$x10000); + $es .= unpack('h4',pack('v',$xr->numify())); } $es = reverse $es; $es =~ s/^[0]+//; # strip leading zeros @@ -2119,11 +2156,11 @@ sub as_bin else { my $x1 = $x->copy()->babs(); my $xr; - my $x100 = Math::BigInt->new (0x100); + my $x10000 = Math::BigInt->new (0x10000); while (!$x1->is_zero()) { - ($x1, $xr) = bdiv($x1,$x100); - $es .= unpack('b8',pack('C',$xr->numify())); + ($x1, $xr) = bdiv($x1,$x10000); + $es .= unpack('b16',pack('v',$xr->numify())); } $es = reverse $es; $es =~ s/^[0]+//; # strip leading zeros diff --git a/lib/Math/BigInt/Calc.pm b/lib/Math/BigInt/Calc.pm index 9424143..d91272e 100644 --- a/lib/Math/BigInt/Calc.pm +++ b/lib/Math/BigInt/Calc.pm @@ -8,7 +8,7 @@ require Exporter; use vars qw/@ISA $VERSION/; @ISA = qw(Exporter); -$VERSION = '0.17'; +$VERSION = '0.20'; # Package to store unsigned big integers in decimal and do math with them @@ -30,9 +30,10 @@ $VERSION = '0.17'; # constants for easier life my $nan = 'NaN'; -my ($BASE,$RBASE,$BASE_LEN,$MAX_VAL,$BASE_LEN2); +my ($MBASE,$BASE,$RBASE,$BASE_LEN,$MAX_VAL,$BASE_LEN2,$BASE_LEN_SMALL); my ($AND_BITS,$XOR_BITS,$OR_BITS); my ($AND_MASK,$XOR_MASK,$OR_MASK); +my ($LEN_CONVERT); sub _base_len { @@ -43,25 +44,34 @@ sub _base_len my $b = shift; if (defined $b) { - $b = 5 if $^O =~ /^uts/; # UTS needs 5, because 6 and 7 break - $BASE_LEN = $b+1; - my $caught; - while (--$BASE_LEN > 5) + # find whether we can use mul or div or none in mul()/div() + # (in last case reduce BASE_LEN_SMALL) + $BASE_LEN_SMALL = $b+1; + my $caught = 0; + while (--$BASE_LEN_SMALL > 5) { - $BASE = int("1e".$BASE_LEN); - $RBASE = abs('1e-'.$BASE_LEN); # see USE_MUL + $MBASE = int("1e".$BASE_LEN_SMALL); + $RBASE = abs('1e-'.$BASE_LEN_SMALL); # see USE_MUL $caught = 0; - $caught += 1 if (int($BASE * $RBASE) != 1); # should be 1 - $caught += 2 if (int($BASE / $BASE) != 1); # should be 1 - # print "caught $caught\n"; + $caught += 1 if (int($MBASE * $RBASE) != 1); # should be 1 + $caught += 2 if (int($MBASE / $MBASE) != 1); # should be 1 last if $caught != 3; } + # BASE_LEN is used for anything else than mul()/div() + $BASE_LEN = $BASE_LEN_SMALL; + $BASE_LEN = shift if (defined $_[0]); # one more arg? $BASE = int("1e".$BASE_LEN); - $RBASE = abs('1e-'.$BASE_LEN); # see USE_MUL - $MAX_VAL = $BASE-1; - $BASE_LEN2 = int($BASE_LEN / 2); # for mul shortcut - # print "BASE_LEN: $BASE_LEN MAX_VAL: $MAX_VAL BASE: $BASE RBASE: $RBASE\n"; - + + $BASE_LEN2 = int($BASE_LEN_SMALL / 2); # for mul shortcut + $MBASE = int("1e".$BASE_LEN_SMALL); + $RBASE = abs('1e-'.$BASE_LEN_SMALL); # see USE_MUL + $MAX_VAL = $MBASE-1; + $LEN_CONVERT = 0; + $LEN_CONVERT = 1 if $BASE_LEN_SMALL != $BASE_LEN; + + #print "BASE_LEN: $BASE_LEN MAX_VAL: $MAX_VAL BASE: $BASE RBASE: $RBASE "; + #print "BASE_LEN_SMALL: $BASE_LEN_SMALL MBASE: $MBASE\n"; + if ($caught & 1 != 0) { # must USE_MUL @@ -75,11 +85,8 @@ sub _base_len *{_div} = \&_div_use_div; } } - if (wantarray) - { - return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS); - } - $BASE_LEN; + return $BASE_LEN unless wantarray; + return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN_SMALL, $MAX_VAL); } BEGIN @@ -92,7 +99,6 @@ BEGIN { $num = ('9' x ++$e) + 0; $num *= $num + 1.0; - # print "$num $e\n"; } while ("$num" =~ /9{$e}0{$e}/); # must be a certain pattern $e--; # last test failed, so retract one step # the limits below brush the problems with the test above under the rug: @@ -102,11 +108,31 @@ BEGIN # there, but we play safe) $e = 8 if $e > 8; # cap, for VMS, OS/390 and other 64 bit systems - __PACKAGE__->_base_len($e); # set and store + # determine how many digits fit into an integer and can be safely added + # together plus carry w/o causing an overflow + + # this below detects 15 on a 64 bit system, because after that it becomes + # 1e16 and not 1000000 :/ I can make it detect 18, but then I get a lot of + # test failures. Ugh! (Tomake detect 18: uncomment lines marked with *) + use integer; + my $bi = 5; # approx. 16 bit + $num = int('9' x $bi); + # $num = 99999; # * + # while ( ($num+$num+1) eq '1' . '9' x $bi) # * + while ( int($num+$num+1) eq '1' . '9' x $bi) + { + $bi++; $num = int('9' x $bi); + # $bi++; $num *= 10; $num += 9; # * + } + $bi--; # back off one step + # by setting them equal, we ignore the findings and use the default + # one-size-fits-all approach from former versions + $bi = $e; # XXX, this should work always + + __PACKAGE__->_base_len($e,$bi); # set and store # find out how many bits _and, _or and _xor can take (old default = 16) # I don't think anybody has yet 128 bit scalars, so let's play safe. - use integer; local $^W = 0; # don't warn about 'nonportable number' $AND_BITS = 15; $XOR_BITS = 15; $OR_BITS = 15; @@ -134,11 +160,76 @@ BEGIN } while ($OR_BITS < $max && $x == $z && $y == $x); $OR_BITS --; # retreat one step - # print "AND $AND_BITS XOR $XOR_BITS OR $OR_BITS\n"; } ############################################################################## -# create objects from various representations +# convert between the "small" and the "large" representation + +sub _to_large + { + # take an array in base $BASE_LEN_SMALL and convert it in-place to $BASE_LEN + my ($c,$x) = @_; + +# print "_to_large $BASE_LEN_SMALL => $BASE_LEN\n"; + + return $x if $LEN_CONVERT == 0 || # nothing to converconvertor + @$x == 1; # only one element => early out + + # 12345 67890 12345 67890 contents + # to 3 2 1 0 index + # 123456 7890123 4567890 contents + +# # faster variant +# my @d; my $str = ''; +# my $z = '0' x $BASE_LEN_SMALL; +# foreach (@$x) +# { +# # ... . 04321 . 000321 +# $str = substr($z.$_,-$BASE_LEN_SMALL,$BASE_LEN_SMALL) . $str; +# if (length($str) > $BASE_LEN) +# { +# push @d, substr($str,-$BASE_LEN,$BASE_LEN); # extract one piece +# substr($str,-$BASE_LEN,$BASE_LEN) = ''; # remove it +# } +# } +# push @d, $str if $str !~ /^0*$/; # extract last piece +# @$x = @d; +# $x->[-1] = int($x->[-1]); # strip leading zero +# $x; + + my $ret = ""; + my $l = scalar @$x; # number of parts + $l --; $ret .= int($x->[$l]); $l--; + my $z = '0' x ($BASE_LEN_SMALL-1); + while ($l >= 0) + { + $ret .= substr($z.$x->[$l],-$BASE_LEN_SMALL); + $l--; + } + my $str = _new($c,\$ret); # make array + @$x = @$str; # clobber contents of $x + $x->[-1] = int($x->[-1]); # strip leading zero + } + +sub _to_small + { + # take an array in base $BASE_LEN and convert it in-place to $BASE_LEN_SMALL + my ($c,$x) = @_; + + return $x if $LEN_CONVERT == 0; # nothing to do + return $x if @$x == 1 && length(int($x->[0])) <= $BASE_LEN_SMALL; + + my $d = _str($c,$x); + my $il = length($$d)-1; + ## this leaves '00000' instead of int 0 and will be corrected after any op + # clobber contents of $x + @$x = reverse(unpack("a" . ($il % $BASE_LEN_SMALL+1) + . ("a$BASE_LEN_SMALL" x ($il / $BASE_LEN_SMALL)), $$d)); + + $x->[-1] = int($x->[-1]); # strip leading zero + } + +############################################################################### sub _new { @@ -146,9 +237,9 @@ sub _new # Convert a number from string format to internal base 100000 format. # Assumes normalized value as input. my $d = $_[1]; - my $il = CORE::length($$d)-1; - # these leaves '00000' instead of int 0 and will be corrected after any op - return [ reverse(unpack("a" . ($il % $BASE_LEN+1) + my $il = length($$d)-1; + # this leaves '00000' instead of int 0 and will be corrected after any op + [ reverse(unpack("a" . ($il % $BASE_LEN+1) . ("a$BASE_LEN" x ($il / $BASE_LEN)), $$d)) ]; } @@ -162,24 +253,24 @@ BEGIN sub _zero { # create a zero - return [ 0 ]; + [ 0 ]; } sub _one { # create a one - return [ 1 ]; + [ 1 ]; } sub _two { # create a two (for _pow) - return [ 2 ]; + [ 2 ]; } sub _copy { - return [ @{$_[1]} ]; + [ @{$_[1]} ]; } # catch and throw away @@ -195,11 +286,13 @@ sub _str # internal format is always normalized (no leading zeros, "-0" => "+0") my $ar = $_[1]; my $ret = ""; - my $l = scalar @$ar; # number of parts - return $nan if $l < 1; # should not happen + + my $l = scalar @$ar; # number of parts + return $nan if $l < 1; # should not happen + # handle first one different to strip leading zeros from it (there are no # leading zero parts in internal representation) - $l --; $ret .= $ar->[$l]; $l--; + $l --; $ret .= int($ar->[$l]); $l--; # Interestingly, the pre-padd method uses more time # the old grep variant takes longer (14 to 10 sec) my $z = '0' x ($BASE_LEN-1); @@ -208,7 +301,7 @@ sub _str $ret .= substr($z.$ar->[$l],-$BASE_LEN); # fastest way I could think of $l--; } - return \$ret; + \$ret; } sub _num @@ -222,7 +315,7 @@ sub _num { $num += $fac*$_; $fac *= $BASE; } - return $num; + $num; } ############################################################################## @@ -252,7 +345,7 @@ sub _add { $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; $j++; } - return $x; + $x; } sub _inc @@ -265,13 +358,10 @@ sub _inc for my $i (@$x) { return $x if (($i += 1) < $BASE); # early out - $i -= $BASE; + $i = 0; # overflow, next } - if ($x->[-1] == 0) # last overflowed - { - push @$x,1; # extend - } - return $x; + push @$x,1 if ($x->[-1] == 0); # last overflowed, so extend + $x; } sub _dec @@ -281,13 +371,14 @@ sub _dec # This routine clobbers up array x, but not y. my ($c,$x) = @_; + my $MAX = $BASE-1; # since MAX_VAL based on MBASE for my $i (@$x) { last if (($i -= 1) >= 0); # early out - $i = $MAX_VAL; + $i = $MAX; # overflow, next } pop @$x if $x->[-1] == 0 && @$x > 1; # last overflowed (but leave 0) - return $x; + $x; } sub _sub @@ -330,6 +421,7 @@ sub _mul_use_mul # shortcut for two very short numbers # +0 since part maybe string '00001' from new() + # works also if xv and yv are the same reference if ((@$xv == 1) && (@$yv == 1) && (length($xv->[0]+0) <= $BASE_LEN2) && (length($yv->[0]+0) <= $BASE_LEN2)) @@ -338,9 +430,15 @@ sub _mul_use_mul return $xv; } - my @prod = (); my ($prod,$car,$cty,$xi,$yi); # since multiplying $x with $x fails, make copy in this case $yv = [@$xv] if "$xv" eq "$yv"; # same references? + if ($LEN_CONVERT != 0) + { + $c->_to_small($xv); $c->_to_small($yv); + } + + my @prod = (); my ($prod,$car,$cty,$xi,$yi); + for $xi (@$xv) { $car = 0; $cty = 0; @@ -350,7 +448,7 @@ sub _mul_use_mul # { # $prod = $xi * $yi + ($prod[$cty] || 0) + $car; # $prod[$cty++] = -# $prod - ($car = int($prod * RBASE)) * $BASE; # see USE_MUL +# $prod - ($car = int($prod * RBASE)) * $MBASE; # see USE_MUL # } # $prod[$cty] += $car if $car; # need really to check for 0? # $xi = shift @prod; @@ -364,13 +462,22 @@ sub _mul_use_mul ## this is actually a tad slower ## $prod = $prod[$cty]; $prod += ($car + $xi * $yi); # no ||0 here $prod[$cty++] = - $prod - ($car = int($prod * $RBASE)) * $BASE; # see USE_MUL + $prod - ($car = int($prod * $RBASE)) * $MBASE; # see USE_MUL } $prod[$cty] += $car if $car; # need really to check for 0? $xi = shift @prod || 0; # || 0 makes v5.005_3 happy } push @$xv, @prod; - __strip_zeros($xv); + if ($LEN_CONVERT != 0) + { + $c->_to_large($yv); + $c->_to_large($xv); + } + else + { + __strip_zeros($xv); + } + $xv; } sub _mul_use_div @@ -382,6 +489,7 @@ sub _mul_use_div # shortcut for two very short numbers # +0 since part maybe string '00001' from new() + # works also if xv and yv are the same reference if ((@$xv == 1) && (@$yv == 1) && (length($xv->[0]+0) <= $BASE_LEN2) && (length($yv->[0]+0) <= $BASE_LEN2)) @@ -389,10 +497,15 @@ sub _mul_use_div $xv->[0] *= $yv->[0]; return $xv; } - - my @prod = (); my ($prod,$car,$cty,$xi,$yi); + # since multiplying $x with $x fails, make copy in this case $yv = [@$xv] if "$xv" eq "$yv"; # same references? + if ($LEN_CONVERT != 0) + { + $c->_to_small($xv); $c->_to_small($yv); + } + + my @prod = (); my ($prod,$car,$cty,$xi,$yi); for $xi (@$xv) { $car = 0; $cty = 0; @@ -402,13 +515,22 @@ sub _mul_use_div { $prod = $xi * $yi + ($prod[$cty] || 0) + $car; $prod[$cty++] = - $prod - ($car = int($prod / $BASE)) * $BASE; + $prod - ($car = int($prod / $MBASE)) * $MBASE; } $prod[$cty] += $car if $car; # need really to check for 0? $xi = shift @prod || 0; # || 0 makes v5.005_3 happy } push @$xv, @prod; - __strip_zeros($xv); + if ($LEN_CONVERT != 0) + { + $c->_to_large($yv); + $c->_to_large($xv); + } + else + { + __strip_zeros($xv); + } + $xv; } sub _div_use_mul @@ -416,25 +538,44 @@ sub _div_use_mul # ref to array, ref to array, modify first array and return remainder if # in list context my ($c,$x,$yorg) = @_; - my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1); - my (@d,$tmp,$q,$u2,$u1,$u0); + if (@$x == 1 && @$yorg == 1) + { + # shortcut, $y is smaller than $x + if (wantarray) + { + my $r = [ $x->[0] % $yorg->[0] ]; + $x->[0] = int($x->[0] / $yorg->[0]); + return ($x,$r); + } + else + { + $x->[0] = int($x->[0] / $yorg->[0]); + return $x; + } + } - $car = $bar = $prd = 0; - my $y = [ @$yorg ]; - if (($dd = int($BASE/($y->[-1]+1))) != 1) + if ($LEN_CONVERT != 0) + { + $c->_to_small($x); $c->_to_small($y); + } + + my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1,@d,$tmp,$q,$u2,$u1,$u0); + + $car = $bar = $prd = 0; + if (($dd = int($MBASE/($y->[-1]+1))) != 1) { for $xi (@$x) { $xi = $xi * $dd + $car; - $xi -= ($car = int($xi * $RBASE)) * $BASE; # see USE_MUL + $xi -= ($car = int($xi * $RBASE)) * $MBASE; # see USE_MUL } push(@$x, $car); $car = 0; for $yi (@$y) { $yi = $yi * $dd + $car; - $yi -= ($car = int($yi * $RBASE)) * $BASE; # see USE_MUL + $yi -= ($car = int($yi * $RBASE)) * $MBASE; # see USE_MUL } } else @@ -449,25 +590,24 @@ sub _div_use_mul $u2 = 0 unless $u2; #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n" # if $v1 == 0; - # $q = (($u0 == $v1) ? 99999 : int(($u0*$BASE+$u1)/$v1)); - $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$BASE+$u1)/$v1)); - --$q while ($v2*$q > ($u0*$BASE+$u1-$q*$v1)*$BASE+$u2); + $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$MBASE+$u1)/$v1)); + --$q while ($v2*$q > ($u0*$MBASE+$u1-$q*$v1)*$MBASE+$u2); if ($q) { ($car, $bar) = (0,0); for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi) { $prd = $q * $y->[$yi] + $car; - $prd -= ($car = int($prd * $RBASE)) * $BASE; # see USE_MUL - $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0)); + $prd -= ($car = int($prd * $RBASE)) * $MBASE; # see USE_MUL + $x->[$xi] += $MBASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0)); } if ($x->[-1] < $car + $bar) { $car = 0; --$q; for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi) { - $x->[$xi] -= $BASE - if ($car = (($x->[$xi] += $y->[$yi] + $car) > $BASE)); + $x->[$xi] -= $MBASE + if ($car = (($x->[$xi] += $y->[$yi] + $car) > $MBASE)); } } } @@ -481,7 +621,7 @@ sub _div_use_mul $car = 0; for $xi (reverse @$x) { - $prd = $car * $BASE + $xi; + $prd = $car * $MBASE + $xi; $car = $prd - ($tmp = int($prd / $dd)) * $dd; # see USE_MUL unshift(@d, $tmp); } @@ -491,15 +631,28 @@ sub _div_use_mul @d = @$x; } @$x = @q; - __strip_zeros($x); - __strip_zeros(\@d); - _check('',$x); - _check('',\@d); - return ($x,\@d); + my $d = \@d; + if ($LEN_CONVERT != 0) + { + $c->_to_large($x); $c->_to_large($d); + } + else + { + __strip_zeros($x); + __strip_zeros($d); + } + return ($x,$d); } @$x = @q; - __strip_zeros($x); - _check('',$x); + if ($LEN_CONVERT != 0) + { + $c->_to_large($x); + } + else + { + __strip_zeros($x); + } + $x; } sub _div_use_div @@ -507,25 +660,44 @@ sub _div_use_div # ref to array, ref to array, modify first array and return remainder if # in list context my ($c,$x,$yorg) = @_; - my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1); - my (@d,$tmp,$q,$u2,$u1,$u0); + if (@$x == 1 && @$yorg == 1) + { + # shortcut, $y is smaller than $x + if (wantarray) + { + my $r = [ $x->[0] % $yorg->[0] ]; + $x->[0] = int($x->[0] / $yorg->[0]); + return ($x,$r); + } + else + { + $x->[0] = int($x->[0] / $yorg->[0]); + return $x; + } + } - $car = $bar = $prd = 0; - my $y = [ @$yorg ]; - if (($dd = int($BASE/($y->[-1]+1))) != 1) + if ($LEN_CONVERT != 0) + { + $c->_to_small($x); $c->_to_small($y); + } + + my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1,@d,$tmp,$q,$u2,$u1,$u0); + + $car = $bar = $prd = 0; + if (($dd = int($MBASE/($y->[-1]+1))) != 1) { for $xi (@$x) { $xi = $xi * $dd + $car; - $xi -= ($car = int($xi / $BASE)) * $BASE; + $xi -= ($car = int($xi / $MBASE)) * $MBASE; } push(@$x, $car); $car = 0; for $yi (@$y) { $yi = $yi * $dd + $car; - $yi -= ($car = int($yi / $BASE)) * $BASE; + $yi -= ($car = int($yi / $MBASE)) * $MBASE; } } else @@ -540,29 +712,28 @@ sub _div_use_div $u2 = 0 unless $u2; #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n" # if $v1 == 0; - # $q = (($u0 == $v1) ? 99999 : int(($u0*$BASE+$u1)/$v1)); - $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$BASE+$u1)/$v1)); - --$q while ($v2*$q > ($u0*$BASE+$u1-$q*$v1)*$BASE+$u2); + $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$MBASE+$u1)/$v1)); + --$q while ($v2*$q > ($u0*$MBASE+$u1-$q*$v1)*$MBASE+$u2); if ($q) { ($car, $bar) = (0,0); for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi) { $prd = $q * $y->[$yi] + $car; - $prd -= ($car = int($prd / $BASE)) * $BASE; - $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0)); + $prd -= ($car = int($prd / $MBASE)) * $MBASE; + $x->[$xi] += $MBASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0)); } if ($x->[-1] < $car + $bar) { $car = 0; --$q; for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi) { - $x->[$xi] -= $BASE - if ($car = (($x->[$xi] += $y->[$yi] + $car) > $BASE)); + $x->[$xi] -= $MBASE + if ($car = (($x->[$xi] += $y->[$yi] + $car) > $MBASE)); } } } - pop(@$x); unshift(@q, $q); + pop(@$x); unshift(@q, $q); } if (wantarray) { @@ -572,7 +743,7 @@ sub _div_use_div $car = 0; for $xi (reverse @$x) { - $prd = $car * $BASE + $xi; + $prd = $car * $MBASE + $xi; $car = $prd - ($tmp = int($prd / $dd)) * $dd; unshift(@d, $tmp); } @@ -582,12 +753,28 @@ sub _div_use_div @d = @$x; } @$x = @q; - __strip_zeros($x); - __strip_zeros(\@d); - return ($x,\@d); + my $d = \@d; + if ($LEN_CONVERT != 0) + { + $c->_to_large($x); $c->_to_large($d); + } + else + { + __strip_zeros($x); + __strip_zeros($d); + } + return ($x,$d); } @$x = @q; - __strip_zeros($x); + if ($LEN_CONVERT != 0) + { + $c->_to_large($x); + } + else + { + __strip_zeros($x); + } + $x; } ############################################################################## @@ -601,7 +788,7 @@ sub _acmp my ($c,$cx,$cy) = @_; - # fat comp based on array elements + # fast comp based on array elements my $lxy = scalar @$cx - scalar @$cy; return -1 if $lxy < 0; # already differs, ret return 1 if $lxy > 0; # ditto @@ -624,7 +811,8 @@ sub _acmp } return 1 if $a > 0; return -1 if $a < 0; - return 0; # equal + 0; # equal + # while it early aborts, it is even slower than the manual variant #grep { return $a if ($a = $_ - $cy->[$i++]); } @$cx; # grep way, go trough all (bad for early ne) @@ -675,12 +863,12 @@ sub _zeros $elem = "$e"; # preserve x $elem =~ s/.*?(0*$)/$1/; # strip anything not zero $zeros *= $BASE_LEN; # elems * 5 - $zeros += CORE::length($elem); # count trailing zeros + $zeros += length($elem); # count trailing zeros last; # early out } $zeros ++; # real else branch: 50% slower! } - return $zeros; + $zeros; } ############################################################################## @@ -690,28 +878,31 @@ sub _is_zero { # return true if arg (BINT or num_str) is zero (array '+', '0') my $x = $_[1]; - return (((scalar @$x == 1) && ($x->[0] == 0))) <=> 0; + + (((scalar @$x == 1) && ($x->[0] == 0))) <=> 0; } sub _is_even { # return true if arg (BINT or num_str) is even my $x = $_[1]; - return (!($x->[0] & 1)) <=> 0; + (!($x->[0] & 1)) <=> 0; } sub _is_odd { # return true if arg (BINT or num_str) is even my $x = $_[1]; - return (($x->[0] & 1)) <=> 0; + + (($x->[0] & 1)) <=> 0; } sub _is_one { # return true if arg (BINT or num_str) is one (array '+', '1') my $x = $_[1]; - return (scalar @$x == 1) && ($x->[0] == 1) <=> 0; + + (scalar @$x == 1) && ($x->[0] == 1) <=> 0; } sub __strip_zeros @@ -724,6 +915,8 @@ sub __strip_zeros my $i = $cnt-1; push @$s,0 if $i < 0; # div might return empty results, so fix it + return $s if @$s == 1; # early out + #print "strip: cnt $cnt i $i\n"; # '0', '3', '4', '0', '0', # 0 1 2 3 4 @@ -794,7 +987,7 @@ sub _mod return $x; } - # @y is single element, but @x has more than one + # @y is single element, but @x has more than one my $b = $BASE % $y; if ($b == 0) { @@ -830,7 +1023,7 @@ sub _mod $x->[0] = $r; } splice (@$x,1); - return $x; + $x; } ############################################################################## @@ -842,39 +1035,37 @@ sub _rsft if ($n != 10) { - return; # we cant do this here, due to now _pow, so signal failure + $n = _new($c,\$n); return _div($c,$x, _pow($c,$n,$y)); + } + + # shortcut (faster) for shifting by 10) + # multiples of $BASE_LEN + my $dst = 0; # destination + my $src = _num($c,$y); # as normal int + my $rem = $src % $BASE_LEN; # remainder to shift + $src = int($src / $BASE_LEN); # source + if ($rem == 0) + { + splice (@$x,0,$src); # even faster, 38.4 => 39.3 } else { - # shortcut (faster) for shifting by 10) - # multiples of $BASE_LEN - my $dst = 0; # destination - my $src = _num($c,$y); # as normal int - my $rem = $src % $BASE_LEN; # remainder to shift - $src = int($src / $BASE_LEN); # source - if ($rem == 0) + my $len = scalar @$x - $src; # elems to go + my $vd; my $z = '0'x $BASE_LEN; + $x->[scalar @$x] = 0; # avoid || 0 test inside loop + while ($dst < $len) { - splice (@$x,0,$src); # even faster, 38.4 => 39.3 + $vd = $z.$x->[$src]; + $vd = substr($vd,-$BASE_LEN,$BASE_LEN-$rem); + $src++; + $vd = substr($z.$x->[$src],-$rem,$rem) . $vd; + $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN; + $x->[$dst] = int($vd); + $dst++; } - else - { - my $len = scalar @$x - $src; # elems to go - my $vd; my $z = '0'x $BASE_LEN; - $x->[scalar @$x] = 0; # avoid || 0 test inside loop - while ($dst < $len) - { - $vd = $z.$x->[$src]; - $vd = substr($vd,-$BASE_LEN,$BASE_LEN-$rem); - $src++; - $vd = substr($z.$x->[$src],-$rem,$rem) . $vd; - $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN; - $x->[$dst] = int($vd); - $dst++; - } - splice (@$x,$dst) if $dst > 0; # kill left-over array elems - pop @$x if $x->[-1] == 0; # kill last element if 0 - } # else rem == 0 - } + splice (@$x,$dst) if $dst > 0; # kill left-over array elems + pop @$x if $x->[-1] == 0; # kill last element if 0 + } # else rem == 0 $x; } @@ -884,33 +1075,31 @@ sub _lsft if ($n != 10) { - return; # we cant do this here, due to now _pow, so signal failure + $n = _new($c,\$n); return _mul($c,$x, _pow($c,$n,$y)); } - else + + # shortcut (faster) for shifting by 10) since we are in base 10eX + # multiples of $BASE_LEN: + my $src = scalar @$x; # source + my $len = _num($c,$y); # shift-len as normal int + my $rem = $len % $BASE_LEN; # remainder to shift + my $dst = $src + int($len/$BASE_LEN); # destination + my $vd; # further speedup + $x->[$src] = 0; # avoid first ||0 for speed + my $z = '0' x $BASE_LEN; + while ($src >= 0) { - # shortcut (faster) for shifting by 10) since we are in base 10eX - # multiples of $BASE_LEN: - my $src = scalar @$x; # source - my $len = _num($c,$y); # shift-len as normal int - my $rem = $len % $BASE_LEN; # remainder to shift - my $dst = $src + int($len/$BASE_LEN); # destination - my $vd; # further speedup - $x->[$src] = 0; # avoid first ||0 for speed - my $z = '0' x $BASE_LEN; - while ($src >= 0) - { - $vd = $x->[$src]; $vd = $z.$vd; - $vd = substr($vd,-$BASE_LEN+$rem,$BASE_LEN-$rem); - $vd .= $src > 0 ? substr($z.$x->[$src-1],-$BASE_LEN,$rem) : '0' x $rem; - $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN; - $x->[$dst] = int($vd); - $dst--; $src--; - } - # set lowest parts to 0 - while ($dst >= 0) { $x->[$dst--] = 0; } - # fix spurios last zero element - splice @$x,-1 if $x->[-1] == 0; + $vd = $x->[$src]; $vd = $z.$vd; + $vd = substr($vd,-$BASE_LEN+$rem,$BASE_LEN-$rem); + $vd .= $src > 0 ? substr($z.$x->[$src-1],-$BASE_LEN,$rem) : '0' x $rem; + $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN; + $x->[$dst] = int($vd); + $dst--; $src--; } + # set lowest parts to 0 + while ($dst >= 0) { $x->[$dst--] = 0; } + # fix spurios last zero element + splice @$x,-1 if $x->[-1] == 0; $x; } @@ -930,10 +1119,10 @@ sub _pow _mul($c,$cx,$cx); } _mul($c,$cx,$pow2) unless _is_one($c,$pow2); - return $cx; + $cx; } -sub _sqrt +sub _sqrt1 { # square-root of $x # ref to array, return ref to array @@ -946,12 +1135,20 @@ sub _sqrt return $x; } my $y = _copy($c,$x); - my $l = [ _len($c,$x) / 2 ]; + my $l = _len($c,$x) / 2; # hopefully _len/2 is < $BASE + # my $l2 = [ _len($c,$x) / 2 ]; # old way: hopefully _len/2 is < $BASE splice @$x,0; $x->[0] = 1; # keep ref($x), but modify it - _lsft($c,$x,$l,10); + # old way + # _lsft($c,$x,$l2,10); + # construct $x (instead of _lsft($c,$x,$l,10) + my $r = $l % $BASE_LEN; # 10000 00000 00000 00000 ($BASE_LEN=5) + $l = int($l / $BASE_LEN); + $x->[$l--] = int('1' . '0' x $r); + $x->[$l--] = 0 while ($l >= 0); + my $two = _two(); my $last = _zero(); my $lastlast = _zero(); @@ -1000,7 +1197,8 @@ sub _and # $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; } # _add($c,$x, _mul($c, _new( $c, \($xrr & $yrr) ), $m) ); - _add($c,$x, _mul($c, [ $xr->[0] & $yr->[0] ], $m) ); + # 0+ due to '&' doesn't work in strings + _add($c,$x, _mul($c, [ 0+$xr->[0] & 0+$yr->[0] ], $m) ); _mul($c,$m,$mask); } $x; @@ -1028,8 +1226,9 @@ sub _xor #$b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; } #$b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; } #_add($c,$x, _mul($c, _new( $c, \($xrr ^ $yrr) ), $m) ); - - _add($c,$x, _mul($c, [ $xr->[0] ^ $yr->[0] ], $m) ); + + # 0+ due to '^' doesn't work in strings + _add($c,$x, _mul($c, [ 0+$xr->[0] ^ 0+$yr->[0] ], $m) ); _mul($c,$m,$mask); } # the loop stops when the shorter of the two numbers is exhausted @@ -1064,7 +1263,8 @@ sub _or # $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; } # _add($c,$x, _mul($c, _new( $c, \($xrr | $yrr) ), $m) ); - _add($c,$x, _mul($c, [ $xr->[0] | $yr->[0] ], $m) ); + # 0+ due to '|' doesn't work in strings + _add($c,$x, _mul($c, [ 0+$xr->[0] | 0+$yr->[0] ], $m) ); _mul($c,$m,$mask); } # the loop stops when the shorter of the two numbers is exhausted @@ -1076,6 +1276,48 @@ sub _or $x; } +sub _as_hex + { + # convert a decimal number to hex (ref to array, return ref to string) + my ($c,$x) = @_; + + my $x1 = _copy($c,$x); + + my $es = ''; + my $xr; + my $x10000 = [ 0x10000 ]; + while (! _is_zero($c,$x1)) + { + ($x1, $xr) = _div($c,$x1,$x10000); + $es .= unpack('h4',pack('v',$xr->[0])); + } + $es = reverse $es; + $es =~ s/^[0]+//; # strip leading zeros + $es = '0x' . $es; + \$es; + } + +sub _as_bin + { + # convert a decimal number to bin (ref to array, return ref to string) + my ($c,$x) = @_; + + my $x1 = _copy($c,$x); + + my $es = ''; + my $xr; + my $x10000 = [ 0x10000 ]; + while (! _is_zero($c,$x1)) + { + ($x1, $xr) = _div($c,$x1,$x10000); + $es .= unpack('b16',pack('v',$xr->[0])); + } + $es = reverse $es; + $es =~ s/^[0]+//; # strip leading zeros + $es = '0b' . $es; + \$es; + } + sub _from_hex { # convert a hex number to decimal (ref to string, return ref to array) @@ -1085,7 +1327,7 @@ sub _from_hex my $m = [ 0x10000 ]; # 16 bit at a time my $x = _zero(); - my $len = CORE::length($$hs)-2; + my $len = length($$hs)-2; $len = int($len/4); # 4-digit parts, w/o '0x' my $val; my $i = -4; while ($len >= 0) @@ -1109,7 +1351,7 @@ sub _from_bin my $m = [ 0x100 ]; # 8 bit at a time my $x = _zero(); - my $len = CORE::length($$bs)-2; + my $len = length($$bs)-2; $len = int($len/8); # 4-digit parts, w/o '0x' my $val; my $i = -8; while ($len >= 0) @@ -1117,8 +1359,6 @@ sub _from_bin $val = substr($$bs,$i,8); $val =~ s/^[+-]?0b// if $len == 0; # for last part only - #$val = oct('0b'.$val); # does not work on Perl prior to 5.6.0 - # $val = ('0' x (8-CORE::length($val))).$val if CORE::length($val) < 8; $val = ord(pack('B8',substr('00000000'.$val,-8,8))); $i -= 8; $len --; diff --git a/lib/Math/BigInt/t/bare_mbi.t b/lib/Math/BigInt/t/bare_mbi.t index 03aed46..5b2df41 100644 --- a/lib/Math/BigInt/t/bare_mbi.t +++ b/lib/Math/BigInt/t/bare_mbi.t @@ -8,7 +8,6 @@ BEGIN $| = 1; # to locate the testing files my $location = $0; $location =~ s/bare_mbi.t//i; - print "loc $location\n"; if ($ENV{PERL_CORE}) { # testing with the core distribution @@ -27,16 +26,18 @@ BEGIN } print "# INC = @INC\n"; - plan tests => 1865; + plan tests => 2005; } use Math::BigInt lib => 'BareCalc'; +print "# ",Math::BigInt::_core_lib(),"\n"; + use vars qw ($class $try $x $y $f @args $ans $ans1 $ans1_str $setup $CL); $class = "Math::BigInt"; $CL = "Math::BigInt::BareCalc"; -my $version = '1.48'; # for $VERSION tests, match current release (by hand!) +my $version = '1.49'; # for $VERSION tests, match current release (by hand!) require 'bigintpm.inc'; # perform same tests as bigintpm diff --git a/lib/Math/BigInt/t/bigfltpm.inc b/lib/Math/BigInt/t/bigfltpm.inc index b61af2a..a5e527e 100644 --- a/lib/Math/BigInt/t/bigfltpm.inc +++ b/lib/Math/BigInt/t/bigfltpm.inc @@ -76,6 +76,8 @@ while () $try .= "\$y = new $class \"$args[1]\";"; if ($f eq "fcmp") { $try .= '$x <=> $y;'; + } elsif ($f eq "flog") { + $try .= '$x->flog($y);'; } elsif ($f eq "facmp") { $try .= '$x->facmp($y);'; } elsif ($f eq "fpow") { @@ -139,6 +141,7 @@ ok ($y,1200); ok ($x,1200); ############################################################################### # fdiv() in list context + $x = $class->bzero(); ($x,$y) = $x->fdiv(0); ok ($x,'NaN'); ok ($y,'NaN'); @@ -150,6 +153,26 @@ $x = $class->new(2); $x->fzero(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); $x = $class->new(2); $x->finf(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); $x = $class->new(2); $x->fone(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); $x = $class->new(2); $x->fnan(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); + +############################################################################### +# fsqrt() with set global A/P or A/P enabled on $x, also a test whether fsqrt() +# correctly modifies $x + +$class->accuracy(undef); $class->precision(undef); # reset + +$x = $class->new(12); $class->precision(-2); $x->fsqrt(); ok ($x,'3.46'); + +$class->precision(undef); +$x = $class->new(12); $class->precision(0); $x->fsqrt(); ok ($x,'3'); + +$class->precision(-3); $x = $class->new(12); $x->fsqrt(); ok ($x,'3.464'); + +# A and P set => NaN +$class->accuracy(4); $x = $class->new(12); $x->fsqrt(3); ok ($x,'NaN'); +# supplied arg overrides set global +$class->precision(undef); $x = $class->new(12); $x->fsqrt(3); ok ($x,'3.46'); + +$class->accuracy(undef); $class->precision(undef); # reset for further tests 1; # all done @@ -165,6 +188,17 @@ sub ok_undef } __DATA__ +#&flog +#$div_scale = 14; +#10:0:2.30258509299405 +#1000:0:6.90775527898214 +#100:0:4.60517018598809 +#2:0:0.693147180559945 +#3.1415:0:1.14470039286086 +#12345:0:9.42100640177928 +#0.001:0:-6.90775527898214 +## reset for further tests +#$div_scale = 40; &frsft #NaNfrsft:NaN 0:2:0 @@ -924,14 +958,89 @@ $div_scale = 1 # reset scale for further tests $div_scale = 40 &fmod -+0:0:NaN -+0:1:0 -+3:1:0 -#+5:2:1 -#+9:4:1 -#+9:5:4 -#+9000:56:40 -#+56:9000:56 ++9:4:1 ++9:5:4 ++9000:56:40 ++56:9000:56 +# inf handling, see table in doc +0:inf:0 +0:-inf:0 +5:inf:5 +5:-inf:5 +-5:inf:-5 +-5:-inf:-5 +inf:5:0 +-inf:5:0 +inf:-5:0 +-inf:-5:0 +5:5:0 +-5:-5:0 +inf:inf:0 +-inf:-inf:0 +-inf:inf:0 +inf:-inf:0 +8:0:8 +inf:0:inf +# exceptions to reminder rule +-inf:0:-inf +-8:0:-8 +0:0:NaN +abc:abc:NaN +abc:1:abc:NaN +1:abc:NaN +0:0:NaN +0:1:0 +1:0:1 +0:-1:0 +-1:0:-1 +1:1:0 +-1:-1:0 +1:-1:0 +-1:1:0 +1:2:1 +2:1:0 +1000000000:9:1 +2000000000:9:2 +3000000000:9:3 +4000000000:9:4 +5000000000:9:5 +6000000000:9:6 +7000000000:9:7 +8000000000:9:8 +9000000000:9:0 +35500000:113:33 +71000000:226:66 +106500000:339:99 +1000000000:3:1 +10:5:0 +100:4:0 +1000:8:0 +10000:16:0 +999999999999:9:0 +999999999999:99:0 +999999999999:999:0 +999999999999:9999:0 +999999999999999:99999:0 +-9:+5:1 ++9:-5:-1 +-9:-5:-4 +-5:3:1 +-2:3:1 +4:3:1 +1:3:1 +-5:-3:-2 +-2:-3:-2 +4:-3:-2 +1:-3:-2 +4095:4095:0 +100041000510123:3:0 +152403346:12345:4321 +87654321:87654321:0 +# now some floating point tests +123:2.5:0.5 +1230:2.5:0 +123.4:2.5:0.9 +123e1:25:5 &fsqrt +0:0 -1:NaN @@ -953,6 +1062,8 @@ nanfsqrt:NaN # sqrt(1.44) = 1.2, sqrt(e10) = e5 => 12e4 1.44E10:120000 2e10:141421.356237309504880168872420969807857 +# proved to be an endless loop under 7-9 +12:3.464101615137754587054892683011744733886 &is_nan 123:0 abc:1 diff --git a/lib/Math/BigInt/t/bigfltpm.t b/lib/Math/BigInt/t/bigfltpm.t index c31d7f1..2c98122 100755 --- a/lib/Math/BigInt/t/bigfltpm.t +++ b/lib/Math/BigInt/t/bigfltpm.t @@ -26,12 +26,7 @@ BEGIN } print "# INC = @INC\n"; -# unshift @INC, '../lib'; # for running manually -# my $location = $0; $location =~ s/bigfltpm.t//; -# unshift @INC, $location; # to locate the testing files -# # chdir 't' if -d 't'; - - plan tests => 1367; + plan tests => 1528; } use Math::BigInt; diff --git a/lib/Math/BigInt/t/bigintc.t b/lib/Math/BigInt/t/bigintc.t index 05b5fcc..220ce30 100644 --- a/lib/Math/BigInt/t/bigintc.t +++ b/lib/Math/BigInt/t/bigintc.t @@ -8,29 +8,52 @@ BEGIN $| = 1; chdir 't' if -d 't'; unshift @INC, '../lib'; # for running manually - plan tests => 63; + } + +use Math::BigInt::Calc; + +BEGIN + { + my $additional = 0; + $additional = 27 if $Math::BigInt::Calc::VERSION > 0.18; + plan tests => 71 + $additional; } # testing of Math::BigInt::Calc, primarily for interface/api and not for the # math functionality -use Math::BigInt::Calc; - my $C = 'Math::BigInt::Calc'; # pass classname to sub's # _new and _str my $x = $C->_new(\"123"); my $y = $C->_new(\"321"); ok (ref($x),'ARRAY'); ok (${$C->_str($x)},123); ok (${$C->_str($y)},321); +############################################################################### # _add, _sub, _mul, _div ok (${$C->_str($C->_add($x,$y))},444); ok (${$C->_str($C->_sub($x,$y))},123); ok (${$C->_str($C->_mul($x,$y))},39483); ok (${$C->_str($C->_div($x,$y))},123); +############################################################################### +# check that mul/div doesn't change $y +# and returns the same reference, not something new ok (${$C->_str($C->_mul($x,$y))},39483); -ok (${$C->_str($x)},39483); -ok (${$C->_str($y)},321); +ok (${$C->_str($x)},39483); ok (${$C->_str($y)},321); + +ok (${$C->_str($C->_div($x,$y))},123); +ok (${$C->_str($x)},123); ok (${$C->_str($y)},321); + +$x = $C->_new(\"39483"); +my ($x1,$r1) = $C->_div($x,$y); +ok ("$x1","$x"); +$C->_inc($x1); +ok ("$x1","$x"); +ok (${$C->_str($r1)},'0'); + +$x = $C->_new(\"39483"); # reset + +############################################################################### my $z = $C->_new(\"2"); ok (${$C->_str($C->_add($x,$z))},39485); my ($re,$rr) = $C->_div($x,$y); @@ -71,28 +94,16 @@ $x = $C->_new(\"10"); $y = $C->_new(\"3"); ok (${$C->_str($C->_lsft($x,$y,10))},10000); $x = $C->_new(\"20"); $y = $C->_new(\"3"); ok (${$C->_str($C->_lsft($x,$y,10))},20000); + $x = $C->_new(\"128"); $y = $C->_new(\"4"); -if (!defined $C->_lsft($x,$y,2)) - { - ok (1,1) - } -else - { - ok ('_lsft','undef'); - } +ok (${$C->_str($C->_lsft($x,$y,2))}, 128 << 4); + $x = $C->_new(\"1000"); $y = $C->_new(\"3"); ok (${$C->_str($C->_rsft($x,$y,10))},1); $x = $C->_new(\"20000"); $y = $C->_new(\"3"); ok (${$C->_str($C->_rsft($x,$y,10))},20); $x = $C->_new(\"256"); $y = $C->_new(\"4"); -if (!defined $C->_rsft($x,$y,2)) - { - ok (1,1) - } -else - { - ok ('_rsft','undef'); - } +ok (${$C->_str($C->_rsft($x,$y,2))},256 >> 4); # _acmp $x = $C->_new(\"123456789"); @@ -146,11 +157,48 @@ ok (${$C->_str(scalar $C->_and($x,$y))},1); ok (${$C->_str(scalar $C->_from_hex(\"0xFf"))},255); ok (${$C->_str(scalar $C->_from_bin(\"0b10101011"))},160+11); +# _as_hex, _as_bin +ok (${$C->_str(scalar $C->_from_hex( $C->_as_hex( $C->_new(\"128"))))}, 128); +ok (${$C->_str(scalar $C->_from_bin( $C->_as_bin( $C->_new(\"128"))))}, 128); + # _check $x = $C->_new(\"123456789"); ok ($C->_check($x),0); ok ($C->_check(123),'123 is not a reference'); +############################################################################### +# _to_large and _to_small (last since they toy with BASE_LEN etc) + +exit if $Math::BigInt::Calc::VERSION < 0.19; + +$C->_base_len(5,7); $x = [ qw/67890 12345 67890 12345/ ]; $C->_to_large($x); +ok (@$x,3); +ok ($x->[0], '4567890'); ok ($x->[1], '7890123'); ok ($x->[2], '123456'); + +$C->_base_len(5,7); $x = [ qw/54321 54321 54321 54321/ ]; $C->_to_large($x); +ok (@$x,3); +ok ($x->[0], '2154321'); ok ($x->[1], '4321543'); ok ($x->[2], '543215'); + +$C->_base_len(6,7); $x = [ qw/654321 654321 654321 654321/ ]; +$C->_to_large($x); ok (@$x,4); +ok ($x->[0], '1654321'); ok ($x->[1], '2165432'); +ok ($x->[2], '3216543'); ok ($x->[3], '654'); + +$C->_base_len(5,7); $C->_to_small($x); ok (@$x,5); +ok ($x->[0], '54321'); ok ($x->[1], '43216'); +ok ($x->[2], '32165'); ok ($x->[3], '21654'); +ok ($x->[4], '6543'); + +$C->_base_len(7,10); $x = [ qw/0000000 0000000 9999990 9999999/ ]; +$C->_to_large($x); ok (@$x,3); +ok ($x->[0], '0000000000'); ok ($x->[1], '9999900000'); +ok ($x->[2], '99999999'); + +$C->_base_len(7,10); $x = [ qw/0000000 0000000 9999990 9999999 99/ ]; +$C->_to_large($x); ok (@$x,3); +ok ($x->[0], '0000000000'); ok ($x->[1], '9999900000'); +ok ($x->[2], '9999999999'); + # done 1; diff --git a/lib/Math/BigInt/t/bigintpm.inc b/lib/Math/BigInt/t/bigintpm.inc index ad55d68..5d8bddb 100644 --- a/lib/Math/BigInt/t/bigintpm.inc +++ b/lib/Math/BigInt/t/bigintpm.inc @@ -7,8 +7,7 @@ my $version = ${"$class\::VERSION"}; package Math::Foo; -use Math::BigInt; -#use Math::BigInt lib => 'BitVect'; # for testing +use Math::BigInt lib => $main::CL; use vars qw/@ISA/; @ISA = (qw/Math::BigInt/); @@ -45,82 +44,80 @@ while () next if /^#/; # skip comments if (s/^&//) { - $f = $_; + $f = $_; next; } elsif (/^\$/) { - $round_mode = $_; - $round_mode =~ s/^\$/$class\->/; - # print "$round_mode\n"; + $round_mode = $_; $round_mode =~ s/^\$/$class\->/; next; } - else + + @args = split(/:/,$_,99); $ans = pop(@args); + $try = "\$x = $class->new(\"$args[0]\");"; + if ($f eq "bnorm") { - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "\$x = $class->new(\"$args[0]\");"; - if ($f eq "bnorm"){ - $try = "\$x = $class->bnorm(\"$args[0]\");"; - # some is_xxx tests - } elsif ($f =~ /^is_(zero|one|odd|even|negative|positive|nan)$/) { - $try .= "\$x->$f();"; - } elsif ($f eq "as_hex") { - $try .= '$x->as_hex();'; - } elsif ($f eq "as_bin") { - $try .= '$x->as_bin();'; - } elsif ($f eq "is_inf") { - $try .= "\$x->is_inf('$args[1]');"; - } elsif ($f eq "binf") { - $try .= "\$x->binf('$args[1]');"; - } elsif ($f eq "bone") { - $try .= "\$x->bone('$args[1]');"; - # some unary ops - } elsif ($f =~ /^b(nan|floor|ceil|sstr|neg|abs|inc|dec|not|sqrt)$/) { - $try .= "\$x->$f();"; - }elsif ($f eq "length") { - $try .= '$x->length();'; - }elsif ($f eq "exponent"){ - # ->bstr() to see if an object is returned - $try .= '$x = $x->exponent()->bstr();'; - }elsif ($f eq "mantissa"){ - # ->bstr() to see if an object is returned - $try .= '$x = $x->mantissa()->bstr();'; - }elsif ($f eq "parts"){ - $try .= '($m,$e) = $x->parts();'; - # ->bstr() to see if an object is returned - $try .= '$m = $m->bstr(); $m = "NaN" if !defined $m;'; - $try .= '$e = $e->bstr(); $e = "NaN" if !defined $e;'; - $try .= '"$m,$e";'; - } else { - $try .= "\$y = $class->new('$args[1]');"; - if ($f eq "bcmp"){ - $try .= '$x <=> $y;'; - }elsif ($f eq "bround") { + $try = "\$x = $class->bnorm(\"$args[0]\");"; + # some is_xxx tests + } elsif ($f =~ /^is_(zero|one|odd|even|negative|positive|nan)$/) { + $try .= "\$x->$f();"; + } elsif ($f eq "as_hex") { + $try .= '$x->as_hex();'; + } elsif ($f eq "as_bin") { + $try .= '$x->as_bin();'; + } elsif ($f eq "is_inf") { + $try .= "\$x->is_inf('$args[1]');"; + } elsif ($f eq "binf") { + $try .= "\$x->binf('$args[1]');"; + } elsif ($f eq "bone") { + $try .= "\$x->bone('$args[1]');"; + # some unary ops + } elsif ($f =~ /^b(nan|floor|ceil|sstr|neg|abs|inc|dec|not|sqrt)$/) { + $try .= "\$x->$f();"; + } elsif ($f eq "length") { + $try .= '$x->length();'; + } elsif ($f eq "exponent"){ + # ->bstr() to see if an object is returned + $try .= '$x = $x->exponent()->bstr();'; + } elsif ($f eq "mantissa"){ + # ->bstr() to see if an object is returned + $try .= '$x = $x->mantissa()->bstr();'; + } elsif ($f eq "parts"){ + $try .= '($m,$e) = $x->parts();'; + # ->bstr() to see if an object is returned + $try .= '$m = $m->bstr(); $m = "NaN" if !defined $m;'; + $try .= '$e = $e->bstr(); $e = "NaN" if !defined $e;'; + $try .= '"$m,$e";'; + } else { + $try .= "\$y = $class->new('$args[1]');"; + if ($f eq "bcmp") + { + $try .= '$x <=> $y;'; + } elsif ($f eq "bround") { $try .= "$round_mode; \$x->bround(\$y);"; - }elsif ($f eq "bacmp"){ - $try .= '$x->bacmp($y);'; - }elsif ($f eq "badd"){ - $try .= '$x + $y;'; - }elsif ($f eq "bsub"){ - $try .= '$x - $y;'; - }elsif ($f eq "bmul"){ - $try .= '$x * $y;'; - }elsif ($f eq "bdiv"){ - $try .= '$x / $y;'; - }elsif ($f eq "bdiv-list"){ - $try .= 'join (",",$x->bdiv($y));'; + } elsif ($f eq "bacmp"){ + $try .= '$x->bacmp($y);'; + } elsif ($f eq "badd"){ + $try .= '$x + $y;'; + } elsif ($f eq "bsub"){ + $try .= '$x - $y;'; + } elsif ($f eq "bmul"){ + $try .= '$x * $y;'; + } elsif ($f eq "bdiv"){ + $try .= '$x / $y;'; + } elsif ($f eq "bdiv-list"){ + $try .= 'join (",",$x->bdiv($y));'; # overload via x= - }elsif ($f =~ /^.=$/){ - $try .= "\$x $f \$y;"; + } elsif ($f =~ /^.=$/){ + $try .= "\$x $f \$y;"; # overload via x - }elsif ($f =~ /^.$/){ - $try .= "\$x $f \$y;"; - }elsif ($f eq "bmod"){ - $try .= '$x % $y;'; - }elsif ($f eq "bgcd") + } elsif ($f =~ /^.$/){ + $try .= "\$x $f \$y;"; + } elsif ($f eq "bmod"){ + $try .= '$x % $y;'; + } elsif ($f eq "bgcd") { if (defined $args[2]) { - $try .= " \$z = $class->new(\"$args[2]\"); "; + $try .= " \$z = $class->new('$args[2]'); "; } $try .= "$class\::bgcd(\$x, \$y"; $try .= ", \$z" if (defined $args[2]); @@ -130,7 +127,7 @@ while () { if (defined $args[2]) { - $try .= " \$z = $class->new(\"$args[2]\"); "; + $try .= " \$z = $class->new('$args[2]'); "; } $try .= "$class\::blcm(\$x, \$y"; $try .= ", \$z" if (defined $args[2]); @@ -162,31 +159,27 @@ while () }elsif ($f eq "bpow"){ $try .= "\$x ** \$y;"; }elsif ($f eq "digit"){ - $try = "\$x = $class->new(\"$args[0]\"); \$x->digit($args[1]);"; + $try = "\$x = $class->new('$args[0]'); \$x->digit($args[1]);"; } else { warn "Unknown op '$f'"; } + } # end else all other ops + + $ans1 = eval $try; + # convert hex/binary targets to decimal + if ($ans =~ /^(0x0x|0b0b)/) + { + $ans =~ s/^0[xb]//; $ans = Math::BigInt->new($ans)->bstr(); } - # print "trying $try\n"; - $ans1 = eval $try; - # remove leading '+' from target - $ans =~ s/^[+]([0-9])/$1/; - # convert hex/binary targets to decimal - if ($ans =~ /^(0x0x|0b0b)/) - { - $ans =~ s/^0[xb]//; - $ans = Math::BigInt->new($ans)->bstr(); - } - if ($ans eq "") - { - ok_undef ($ans1); - } - else - { - # print "try: $try ans: $ans1 $ans\n"; - print "# Tried: '$try'\n" if !ok ($ans1, $ans); - } - # check internal state of number objects - is_valid($ans1,$f) if ref $ans1; + if ($ans eq "") + { + ok_undef ($ans1); + } + else + { + # print "try: $try ans: $ans1 $ans\n"; + print "# Tried: '$try'\n" if !ok ($ans1, $ans); } + # check internal state of number objects + is_valid($ans1,$f) if ref $ans1; } # endwhile data tests close DATA; @@ -427,7 +420,9 @@ $x -= 1; ok ($x,$MAX); is_valid($x); # 9999 again $x = $class->new($BASE-1); ok ($x->numify(),$BASE-1); $x = $class->new(-($BASE-1)); ok ($x->numify(),-($BASE-1)); -$x = $class->new($BASE); ok ($x->numify(),$BASE); + +# +0 is to protect from 1e15 vs 100000000 (stupid to_string aaaarglburblll...) +$x = $class->new($BASE); ok ($x->numify()+0,$BASE+0); $x = $class->new(-$BASE); ok ($x->numify(),-$BASE); $x = $class->new( -($BASE*$BASE*1+$BASE*1+1) ); ok($x->numify(),-($BASE*$BASE*1+$BASE*1+1)); @@ -454,18 +449,22 @@ ok ($x, 23456); ############################################################################### # bug in shortcut in mul() -# construct a number with a zero-hole of BASE_LEN -$x = '1' x $bl . '0' x $bl . '1' x $bl . '0' x $bl; -$y = '1' x (2*$bl); -$x = $class->new($x)->bmul($y); -# result is 123..$bl . $bl x (3*bl-1) . $bl...321 . '0' x $bl -$y = ''; my $d = ''; -for (my $i = 1; $i <= $bl; $i++) - { - $y .= $i; $d = $i.$d; - } -$y .= $bl x (3*$bl-1) . $d . '0' x $bl; -ok ($x,$y); +# construct a number with a zero-hole of BASE_LEN_SMALL +{ + my @bl = $CL->_base_len(); my $bl = $bl[4]; + + $x = '1' x $bl . '0' x $bl . '1' x $bl . '0' x $bl; + $y = '1' x (2*$bl); + $x = $class->new($x)->bmul($y); + # result is 123..$bl . $bl x (3*bl-1) . $bl...321 . '0' x $bl + $y = ''; my $d = ''; + for (my $i = 1; $i <= $bl; $i++) + { + $y .= $i; $d = $i.$d; + } + $y .= $bl x (3*$bl-1) . $d . '0' x $bl; + ok ($x,$y); + ############################################################################### # see if mul shortcut for small numbers works @@ -475,32 +474,21 @@ $x = $class->new($x); # 999 * 999 => 998 . 001, 9999*9999 => 9998 . 0001 ok ($x*$x, '9' x ($bl-1) . '8' . '0' x ($bl-1) . '1'); + } + ############################################################################### # bug with rest "-0" in div, causing further div()s to fail $x = $class->new('-322056000'); ($x,$y) = $x->bdiv('-12882240'); -ok ($y,'0','not -0'); # not '-0' -is_valid($y); - -############################################################################### -# test whether bone/bzero take additional A & P, or reset it etc - -$x = $class->new(2); $x->bzero(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); -$x = $class->new(2); $x->binf(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); -$x = $class->new(2); $x->bone(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); -$x = $class->new(2); $x->bnan(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); - -$x = $class->new(2); $x->{_a} = 1; $x->{_p} = 2; $x->bnan(); -ok_undef ($x->{_a}); ok_undef ($x->{_p}); -$x = $class->new(2); $x->{_a} = 1; $x->{_p} = 2; $x->binf(); -ok_undef ($x->{_a}); ok_undef ($x->{_p}); +ok ($y,'0'); is_valid($y); # $y not '-0' -### all tests done ############################################################ +# all tests done 1; ############################################################################### +############################################################################### # Perl 5.005 does not like ok ($x,undef) sub ok_undef @@ -636,7 +624,38 @@ NaN:-inf: 0b001:1 0b011:3 0b101:5 -0b1000000000000000000000000000000:1073741824 +0b1001:9 +0b10001:17 +0b100001:33 +0b1000001:65 +0b10000001:129 +0b100000001:257 +0b1000000001:513 +0b10000000001:1025 +0b100000000001:2049 +0b1000000000001:4097 +0b10000000000001:8193 +0b100000000000001:16385 +0b1000000000000001:32769 +0b10000000000000001:65537 +0b100000000000000001:131073 +0b1000000000000000001:262145 +0b10000000000000000001:524289 +0b100000000000000000001:1048577 +0b1000000000000000000001:2097153 +0b10000000000000000000001:4194305 +0b100000000000000000000001:8388609 +0b1000000000000000000000001:16777217 +0b10000000000000000000000001:33554433 +0b100000000000000000000000001:67108865 +0b1000000000000000000000000001:134217729 +0b10000000000000000000000000001:268435457 +0b100000000000000000000000000001:536870913 +0b1000000000000000000000000000001:1073741825 +0b10000000000000000000000000000001:2147483649 +0b100000000000000000000000000000001:4294967297 +0b1000000000000000000000000000000001:8589934593 +0b10000000000000000000000000000000001:17179869185 0b_101:NaN 0b1_0_1:5 0b0_0_0_1:1 @@ -651,6 +670,39 @@ NaN:-inf: 0x1_2_3_4_56_78:305419896 0xa_b_c_d_e_f:11259375 0x_123:NaN +0x9:9 +0x11:17 +0x21:33 +0x41:65 +0x81:129 +0x101:257 +0x201:513 +0x401:1025 +0x801:2049 +0x1001:4097 +0x2001:8193 +0x4001:16385 +0x8001:32769 +0x10001:65537 +0x20001:131073 +0x40001:262145 +0x80001:524289 +0x100001:1048577 +0x200001:2097153 +0x400001:4194305 +0x800001:8388609 +0x1000001:16777217 +0x2000001:33554433 +0x4000001:67108865 +0x8000001:134217729 +0x10000001:268435457 +0x20000001:536870913 +0x40000001:1073741825 +0x80000001:2147483649 +0x100000001:4294967297 +0x200000001:8589934593 +0x400000001:17179869185 +0x800000001:34359738369 # inf input inf:inf +inf:inf @@ -686,6 +738,19 @@ E23:NaN 1e2e3:NaN 1e2r:NaN 1e2.0:NaN +# leading zeros +012:12 +0123:123 +01234:1234 +012345:12345 +0123456:123456 +01234567:1234567 +012345678:12345678 +0123456789:123456789 +01234567891:1234567891 +012345678912:12345678912 +0123456789123:123456789123 +01234567891234:1234567891234 # normal input 0:0 +0:0 @@ -728,12 +793,12 @@ E23:NaN 2:NaN abc:NaN &bone -2:+:+1 +2:+:1 2:-:-1 boneNaN:-:-1 -boneNaN:+:+1 -2:abc:+1 -3::+1 +boneNaN:+:1 +2:abc:1 +3::1 &binf 1:+:inf 2:-:-inf @@ -759,27 +824,27 @@ NaN::0 -infinity::0 &blsft abc:abc:NaN -+2:+2:+8 -+1:+32:+4294967296 -+1:+48:+281474976710656 ++2:+2:8 ++1:+32:4294967296 ++1:+48:281474976710656 +8:-2:NaN # excercise base 10 +12345:4:10:123450000 -1234:0:10:-1234 -+1234:0:10:+1234 ++1234:0:10:1234 +2:2:10:200 +12:2:10:1200 +1234:-3:10:NaN 1234567890123:12:10:1234567890123000000000000 &brsft abc:abc:NaN -+8:+2:+2 -+4294967296:+32:+1 -+281474976710656:+48:+1 ++8:+2:2 ++4294967296:+32:1 ++281474976710656:+48:1 +2:-2:NaN # excercise base 10 -1234:0:10:-1234 -+1234:0:10:+1234 ++1234:0:10:1234 +200:2:10:2 +1234:3:10:1 +1234:2:10:12 @@ -799,47 +864,47 @@ bnegNaN:NaN +inf:-inf -inf:inf abd:NaN -+0:+0 -+1:-1 --1:+1 +0:0 +1:-1 +-1:1 +123456789:-123456789 --123456789:+123456789 +-123456789:123456789 &babs babsNaN:NaN +inf:inf -inf:inf -+0:+0 -+1:+1 --1:+1 -+123456789:+123456789 --123456789:+123456789 +0:0 +1:1 +-1:1 ++123456789:123456789 +-123456789:123456789 &bcmp bcmpNaN:bcmpNaN: -bcmpNaN:+0: -+0:bcmpNaN: -+0:+0:0 --1:+0:-1 -+0:-1:1 -+1:+0:1 -+0:+1:-1 --1:+1:-1 -+1:-1:1 +bcmpNaN:0: +0:bcmpNaN: +0:0:0 +-1:0:-1 +0:-1:1 +1:0:1 +0:1:-1 +-1:1:-1 +1:-1:1 -1:-1:0 -+1:+1:0 -+123:+123:0 -+123:+12:1 -+12:+123:-1 +1:1:0 +123:123:0 +123:12:1 +12:123:-1 -123:-123:0 -123:-12:-1 -12:-123:1 -+123:+124:-1 -+124:+123:1 +123:124:-1 +124:123:1 -123:-124:1 -124:-123:-1 -+100:+5:1 --123456789:+987654321:-1 +100:5:1 +-123456789:987654321:-1 +123456789:-987654321:1 --987654321:+123456789:-1 +-987654321:123456789:-1 -inf:5432112345:-1 +inf:5432112345:1 -inf:-5432112345:-1 @@ -861,19 +926,19 @@ NaN:-inf: abc:NaN +inf:inf -inf:-inf -+0:+1 -+1:+2 --1:+0 ++0:1 ++1:2 +-1:0 &bdec abc:NaN +inf:inf -inf:-inf +0:-1 -+1:+0 ++1:0 -1:-2 &badd abc:abc:NaN -abc:+0:NaN +abc:0:NaN +0:abc:NaN +inf:-inf:0 -inf:+inf:0 @@ -883,38 +948,38 @@ baddNaN:+inf:NaN baddNaN:+inf:NaN +inf:baddNaN:NaN -inf:baddNaN:NaN -+0:+0:+0 -+1:+0:+1 -+0:+1:+1 -+1:+1:+2 --1:+0:-1 -+0:-1:-1 +0:0:0 +1:0:1 +0:1:1 +1:1:2 +-1:0:-1 +0:-1:-1 -1:-1:-2 --1:+1:+0 -+1:-1:+0 -+9:+1:+10 -+99:+1:+100 -+999:+1:+1000 -+9999:+1:+10000 -+99999:+1:+100000 -+999999:+1:+1000000 -+9999999:+1:+10000000 -+99999999:+1:+100000000 -+999999999:+1:+1000000000 -+9999999999:+1:+10000000000 -+99999999999:+1:+100000000000 -+10:-1:+9 -+100:-1:+99 -+1000:-1:+999 -+10000:-1:+9999 -+100000:-1:+99999 -+1000000:-1:+999999 -+10000000:-1:+9999999 -+100000000:-1:+99999999 -+1000000000:-1:+999999999 -+10000000000:-1:+9999999999 -+123456789:+987654321:+1111111110 --123456789:+987654321:+864197532 +-1:+1:0 ++1:-1:0 ++9:+1:10 ++99:+1:100 ++999:+1:1000 ++9999:+1:10000 ++99999:+1:100000 ++999999:+1:1000000 ++9999999:+1:10000000 ++99999999:+1:100000000 ++999999999:+1:1000000000 ++9999999999:+1:10000000000 ++99999999999:+1:100000000000 ++10:-1:9 ++100:-1:99 ++1000:-1:999 ++10000:-1:9999 ++100000:-1:99999 ++1000000:-1:999999 ++10000000:-1:9999999 ++100000000:-1:99999999 ++1000000000:-1:999999999 ++10000000000:-1:9999999999 ++123456789:987654321:1111111110 +-123456789:987654321:864197532 -123456789:-987654321:-1111111110 +123456789:-987654321:-864197532 &bsub @@ -925,40 +990,40 @@ abc:+0:NaN -inf:+inf:-inf +inf:+inf:0 -inf:-inf:0 -+0:+0:+0 -+1:+0:+1 ++0:+0:0 ++1:+0:1 +0:+1:-1 -+1:+1:+0 ++1:+1:0 -1:+0:-1 -+0:-1:+1 --1:-1:+0 ++0:-1:1 +-1:-1:0 -1:+1:-2 -+1:-1:+2 -+9:+1:+8 -+99:+1:+98 -+999:+1:+998 -+9999:+1:+9998 -+99999:+1:+99998 -+999999:+1:+999998 -+9999999:+1:+9999998 -+99999999:+1:+99999998 -+999999999:+1:+999999998 -+9999999999:+1:+9999999998 -+99999999999:+1:+99999999998 -+10:-1:+11 -+100:-1:+101 -+1000:-1:+1001 -+10000:-1:+10001 -+100000:-1:+100001 -+1000000:-1:+1000001 -+10000000:-1:+10000001 -+100000000:-1:+100000001 -+1000000000:-1:+1000000001 -+10000000000:-1:+10000000001 ++1:-1:2 ++9:+1:8 ++99:+1:98 ++999:+1:998 ++9999:+1:9998 ++99999:+1:99998 ++999999:+1:999998 ++9999999:+1:9999998 ++99999999:+1:99999998 ++999999999:+1:999999998 ++9999999999:+1:9999999998 ++99999999999:+1:99999999998 ++10:-1:11 ++100:-1:101 ++1000:-1:1001 ++10000:-1:10001 ++100000:-1:100001 ++1000000:-1:1000001 ++10000000:-1:10000001 ++100000000:-1:100000001 ++1000000000:-1:1000000001 ++10000000000:-1:10000000001 +123456789:+987654321:-864197532 -123456789:+987654321:-1111111110 --123456789:-987654321:+864197532 -+123456789:-987654321:+1111111110 +-123456789:-987654321:864197532 ++123456789:-987654321:1111111110 &bmul abc:abc:NaN abc:+0:NaN @@ -971,38 +1036,38 @@ NaNmul:-inf:NaN +inf:-inf:-inf -inf:+inf:-inf -inf:-inf:inf -+0:+0:+0 -+0:+1:+0 -+1:+0:+0 -+0:-1:+0 --1:+0:+0 -+123456789123456789:+0:+0 -+0:+123456789123456789:+0 --1:-1:+1 ++0:+0:0 ++0:+1:0 ++1:+0:0 ++0:-1:0 +-1:+0:0 +123456789123456789:0:0 +0:123456789123456789:0 +-1:-1:1 -1:+1:-1 +1:-1:-1 -+1:+1:+1 -+2:+3:+6 ++1:+1:1 ++2:+3:6 -2:+3:-6 +2:-3:-6 --2:-3:+6 -+111:+111:+12321 -+10101:+10101:+102030201 -+1001001:+1001001:+1002003002001 -+100010001:+100010001:+10002000300020001 -+10000100001:+10000100001:+100002000030000200001 -+11111111111:+9:+99999999999 -+22222222222:+9:+199999999998 -+33333333333:+9:+299999999997 -+44444444444:+9:+399999999996 -+55555555555:+9:+499999999995 -+66666666666:+9:+599999999994 -+77777777777:+9:+699999999993 -+88888888888:+9:+799999999992 -+99999999999:+9:+899999999991 -+25:+25:+625 -+12345:+12345:+152399025 -+99999:+11111:+1111088889 +-2:-3:6 +111:111:12321 +10101:10101:102030201 +1001001:1001001:1002003002001 +100010001:100010001:10002000300020001 +10000100001:10000100001:100002000030000200001 +11111111111:9:99999999999 +22222222222:9:199999999998 +33333333333:9:299999999997 +44444444444:9:399999999996 +55555555555:9:499999999995 +66666666666:9:599999999994 +77777777777:9:699999999993 +88888888888:9:799999999992 +99999999999:9:899999999991 ++25:+25:625 ++12345:+12345:152399025 ++99999:+11111:1111088889 9999:10000:99990000 99999:100000:9999900000 999999:1000000:999999000000 @@ -1057,9 +1122,9 @@ inf:0:inf,inf 0:0:NaN,NaN &bdiv abc:abc:NaN -abc:+1:NaN -+1:abc:NaN -+0:+0:NaN +abc:1:NaN +1:abc:NaN +0:0:NaN # inf handling (see table in doc) 0:inf:0 0:-inf:0 @@ -1086,38 +1151,38 @@ inf:0:inf -11:-2:5 -11:2:-5 11:-2:-5 -+0:+1:+0 -+0:-1:+0 -+1:+1:+1 --1:-1:+1 -+1:-1:-1 --1:+1:-1 -+1:+2:+0 -+2:+1:+2 -+1:+26:+0 -+1000000000:+9:+111111111 -+2000000000:+9:+222222222 -+3000000000:+9:+333333333 -+4000000000:+9:+444444444 -+5000000000:+9:+555555555 -+6000000000:+9:+666666666 -+7000000000:+9:+777777777 -+8000000000:+9:+888888888 -+9000000000:+9:+1000000000 -+35500000:+113:+314159 -+71000000:+226:+314159 -+106500000:+339:+314159 -+1000000000:+3:+333333333 -+10:+5:+2 -+100:+4:+25 -+1000:+8:+125 -+10000:+16:+625 -+999999999999:+9:+111111111111 -+999999999999:+99:+10101010101 -+999999999999:+999:+1001001001 -+999999999999:+9999:+100010001 -+999999999999999:+99999:+10000100001 -+1111088889:+99999:+11111 +0:1:0 +0:-1:0 +1:1:1 +-1:-1:1 +1:-1:-1 +-1:1:-1 +1:2:0 +2:1:2 +1:26:0 +1000000000:9:111111111 +2000000000:9:222222222 +3000000000:9:333333333 +4000000000:9:444444444 +5000000000:9:555555555 +6000000000:9:666666666 +7000000000:9:777777777 +8000000000:9:888888888 +9000000000:9:1000000000 +35500000:113:314159 +71000000:226:314159 +106500000:339:314159 +1000000000:3:333333333 ++10:+5:2 ++100:+4:25 ++1000:+8:125 ++10000:+16:625 +999999999999:9:111111111111 +999999999999:99:10101010101 +999999999999:999:1001001001 +999999999999:9999:100010001 +999999999999999:99999:10000100001 ++1111088889:99999:11111 -5:-3:1 -5:3:-1 4:3:1 @@ -1159,42 +1224,42 @@ inf:0:inf -8:0:-8 0:0:NaN abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0 -+1:+0:+1 -+0:-1:+0 --1:+0:-1 -+1:+1:+0 --1:-1:+0 -+1:-1:+0 --1:+1:+0 -+1:+2:+1 -+2:+1:+0 -+1000000000:+9:+1 -+2000000000:+9:+2 -+3000000000:+9:+3 -+4000000000:+9:+4 -+5000000000:+9:+5 -+6000000000:+9:+6 -+7000000000:+9:+7 -+8000000000:+9:+8 -+9000000000:+9:+0 -+35500000:+113:+33 -+71000000:+226:+66 -+106500000:+339:+99 -+1000000000:+3:+1 -+10:+5:+0 -+100:+4:+0 -+1000:+8:+0 -+10000:+16:+0 -+999999999999:+9:+0 -+999999999999:+99:+0 -+999999999999:+999:+0 -+999999999999:+9999:+0 -+999999999999999:+99999:+0 --9:+5:+1 +abc:1:abc:NaN +1:abc:NaN +0:0:NaN +0:1:0 +1:0:1 +0:-1:0 +-1:0:-1 +1:1:0 +-1:-1:0 +1:-1:0 +-1:1:0 +1:2:1 +2:1:0 +1000000000:9:1 +2000000000:9:2 +3000000000:9:3 +4000000000:9:4 +5000000000:9:5 +6000000000:9:6 +7000000000:9:7 +8000000000:9:8 +9000000000:9:0 +35500000:113:33 +71000000:226:66 +106500000:339:99 +1000000000:3:1 +10:5:0 +100:4:0 +1000:8:0 +10000:16:0 +999999999999:9:0 +999999999999:99:0 +999999999999:999:0 +999999999999:9999:0 +999999999999999:99999:0 +-9:+5:1 +9:-5:-1 -9:-5:-4 -5:3:1 @@ -1212,37 +1277,37 @@ abc:+1:abc:NaN abc:abc:NaN abc:+0:NaN +0:abc:NaN -+0:+0:+0 -+0:+1:+1 -+1:+0:+1 -+1:+1:+1 -+2:+3:+1 -+3:+2:+1 --3:+2:+1 -+100:+625:+25 -+4096:+81:+1 -+1034:+804:+2 -+27:+90:+56:+1 -+27:+90:+54:+9 ++0:+0:0 ++0:+1:1 ++1:+0:1 ++1:+1:1 ++2:+3:1 ++3:+2:1 +-3:+2:1 +100:625:25 +4096:81:1 +1034:804:2 +27:90:56:1 +27:90:54:9 &blcm abc:abc:NaN abc:+0:NaN +0:abc:NaN +0:+0:NaN -+1:+0:+0 -+0:+1:+0 -+27:+90:+270 -+1034:+804:+415668 ++1:+0:0 ++0:+1:0 ++27:+90:270 ++1034:+804:415668 &band abc:abc:NaN abc:0:NaN 0:abc:NaN 1:2:0 3:2:2 -+8:+2:+0 -+281474976710656:+0:+0 -+281474976710656:+1:+0 -+281474976710656:+281474976710656:+281474976710656 ++8:+2:0 ++281474976710656:0:0 ++281474976710656:1:0 ++281474976710656:+281474976710656:281474976710656 -2:-3:-4 -1:-1:-1 -6:-6:-6 @@ -1271,10 +1336,10 @@ abc:abc:NaN abc:0:NaN 0:abc:NaN 1:2:3 -+8:+2:+10 -+281474976710656:+0:+281474976710656 -+281474976710656:+1:+281474976710657 -+281474976710656:+281474976710656:+281474976710656 ++8:+2:10 ++281474976710656:0:281474976710656 ++281474976710656:1:281474976710657 ++281474976710656:281474976710656:281474976710656 -2:-3:-1 -1:-1:-1 -6:-6:-6 @@ -1317,10 +1382,10 @@ abc:abc:NaN abc:0:NaN 0:abc:NaN 1:2:3 -+8:+2:+10 -+281474976710656:+0:+281474976710656 -+281474976710656:+1:+281474976710657 -+281474976710656:+281474976710656:+0 ++8:+2:10 ++281474976710656:0:281474976710656 ++281474976710656:1:281474976710657 ++281474976710656:281474976710656:0 -2:-3:3 -1:-1:0 -6:-6:0 @@ -1513,66 +1578,66 @@ NaNbround:12:NaN 123456:4:123400 123456:5:123450 123456:6:123456 -+10123456789:5:+10123000000 ++10123456789:5:10123000000 -10123456789:5:-10123000000 -+10123456789:9:+10123456700 ++10123456789:9:10123456700 -10123456789:9:-10123456700 -+101234500:6:+101234000 ++101234500:6:101234000 -101234500:6:-101234000 -#+101234500:-4:+101234000 +#+101234500:-4:101234000 #-101234500:-4:-101234000 $round_mode('zero') -+20123456789:5:+20123000000 ++20123456789:5:20123000000 -20123456789:5:-20123000000 -+20123456789:9:+20123456800 ++20123456789:9:20123456800 -20123456789:9:-20123456800 -+201234500:6:+201234000 ++201234500:6:201234000 -201234500:6:-201234000 -#+201234500:-4:+201234000 +#+201234500:-4:201234000 #-201234500:-4:-201234000 +12345000:4:12340000 -12345000:4:-12340000 $round_mode('+inf') -+30123456789:5:+30123000000 ++30123456789:5:30123000000 -30123456789:5:-30123000000 -+30123456789:9:+30123456800 ++30123456789:9:30123456800 -30123456789:9:-30123456800 -+301234500:6:+301235000 ++301234500:6:301235000 -301234500:6:-301234000 -#+301234500:-4:+301235000 +#+301234500:-4:301235000 #-301234500:-4:-301234000 +12345000:4:12350000 -12345000:4:-12340000 $round_mode('-inf') -+40123456789:5:+40123000000 ++40123456789:5:40123000000 -40123456789:5:-40123000000 -+40123456789:9:+40123456800 ++40123456789:9:40123456800 -40123456789:9:-40123456800 -+401234500:6:+401234000 -+401234500:6:+401234000 ++401234500:6:401234000 ++401234500:6:401234000 #-401234500:-4:-401235000 #-401234500:-4:-401235000 +12345000:4:12340000 -12345000:4:-12350000 $round_mode('odd') -+50123456789:5:+50123000000 ++50123456789:5:50123000000 -50123456789:5:-50123000000 -+50123456789:9:+50123456800 ++50123456789:9:50123456800 -50123456789:9:-50123456800 -+501234500:6:+501235000 ++501234500:6:501235000 -501234500:6:-501235000 -#+501234500:-4:+501235000 +#+501234500:-4:501235000 #-501234500:-4:-501235000 +12345000:4:12350000 -12345000:4:-12350000 $round_mode('even') -+60123456789:5:+60123000000 ++60123456789:5:60123000000 -60123456789:5:-60123000000 -+60123456789:9:+60123456800 ++60123456789:9:60123456800 -60123456789:9:-60123456800 -+601234500:6:+601234000 ++601234500:6:601234000 -601234500:6:-601234000 -#+601234500:-4:+601234000 +#+601234500:-4:601234000 #-601234500:-4:-601234000 #-601234500:-9:0 #-501234500:-9:0 diff --git a/lib/Math/BigInt/t/bigintpm.t b/lib/Math/BigInt/t/bigintpm.t index d1fac73..913c19b 100755 --- a/lib/Math/BigInt/t/bigintpm.t +++ b/lib/Math/BigInt/t/bigintpm.t @@ -10,7 +10,7 @@ BEGIN my $location = $0; $location =~ s/bigintpm.t//; unshift @INC, $location; # to locate the testing files chdir 't' if -d 't'; - plan tests => 1865; + plan tests => 2005; } use Math::BigInt; diff --git a/lib/Math/BigInt/t/mbimbf.inc b/lib/Math/BigInt/t/mbimbf.inc new file mode 100644 index 0000000..bdb1271 --- /dev/null +++ b/lib/Math/BigInt/t/mbimbf.inc @@ -0,0 +1,703 @@ +# test rounding, accuracy, precicion and fallback, round_mode and mixing +# of classes + +# Make sure you always quote any bare floating-point values, lest 123.46 will +# be stringified to 123.4599999999 due to limited float prevision. + +my ($x,$y,$z,$u,$rc); + +############################################################################### +# test defaults and set/get + +ok_undef (${"$mbi\::accuracy"}); +ok_undef (${"$mbi\::precision"}); +ok_undef ($mbi->accuracy()); +ok_undef ($mbi->precision()); +ok (${"$mbi\::div_scale"},40); +ok (${"$mbi\::round_mode"},'even'); +ok ($mbi->round_mode(),'even'); + +ok_undef (${"$mbf\::accuracy"}); +ok_undef (${"$mbf\::precision"}); +ok_undef ($mbf->precision()); +ok_undef ($mbf->precision()); +ok (${"$mbf\::div_scale"},40); +ok (${"$mbf\::round_mode"},'even'); +ok ($mbf->round_mode(),'even'); + +# accessors +foreach my $class ($mbi,$mbf) + { + ok_undef ($class->accuracy()); + ok_undef ($class->precision()); + ok ($class->round_mode(),'even'); + ok ($class->div_scale(),40); + + ok ($class->div_scale(20),20); + $class->div_scale(40); ok ($class->div_scale(),40); + + ok ($class->round_mode('odd'),'odd'); + $class->round_mode('even'); ok ($class->round_mode(),'even'); + + ok ($class->accuracy(2),2); + $class->accuracy(3); ok ($class->accuracy(),3); + ok_undef ($class->accuracy(undef)); + + ok ($class->precision(2),2); + ok ($class->precision(-2),-2); + $class->precision(3); ok ($class->precision(),3); + ok_undef ($class->precision(undef)); + } + +# accuracy +foreach (qw/5 42 -1 0/) + { + ok (${"$mbf\::accuracy"} = $_,$_); + ok (${"$mbi\::accuracy"} = $_,$_); + } +ok_undef (${"$mbf\::accuracy"} = undef); +ok_undef (${"$mbi\::accuracy"} = undef); + +# precision +foreach (qw/5 42 -1 0/) + { + ok (${"$mbf\::precision"} = $_,$_); + ok (${"$mbi\::precision"} = $_,$_); + } +ok_undef (${"$mbf\::precision"} = undef); +ok_undef (${"$mbi\::precision"} = undef); + +# fallback +foreach (qw/5 42 1/) + { + ok (${"$mbf\::div_scale"} = $_,$_); + ok (${"$mbi\::div_scale"} = $_,$_); + } +# illegal values are possible for fallback due to no accessor + +# round_mode +foreach (qw/odd even zero trunc +inf -inf/) + { + ok (${"$mbf\::round_mode"} = $_,$_); + ok (${"$mbi\::round_mode"} = $_,$_); + } +${"$mbf\::round_mode"} = 'zero'; +ok (${"$mbf\::round_mode"},'zero'); +ok (${"$mbi\::round_mode"},'-inf'); # from above + +${"$mbi\::accuracy"} = undef; +${"$mbi\::precision"} = undef; +# local copies +$x = $mbf->new('123.456'); +ok_undef ($x->accuracy()); +ok ($x->accuracy(5),5); +ok_undef ($x->accuracy(undef),undef); +ok_undef ($x->precision()); +ok ($x->precision(5),5); +ok_undef ($x->precision(undef),undef); + +# see if MBF changes MBIs values +ok (${"$mbi\::accuracy"} = 42,42); +ok (${"$mbf\::accuracy"} = 64,64); +ok (${"$mbi\::accuracy"},42); # should be still 42 +ok (${"$mbf\::accuracy"},64); # should be now 64 + +############################################################################### +# see if creating a number under set A or P will round it + +${"$mbi\::accuracy"} = 4; +${"$mbi\::precision"} = undef; + +ok ($mbi->new(123456),123500); # with A +${"$mbi\::accuracy"} = undef; +${"$mbi\::precision"} = 3; +ok ($mbi->new(123456),123000); # with P + +${"$mbf\::accuracy"} = 4; +${"$mbf\::precision"} = undef; +${"$mbi\::precision"} = undef; + +ok ($mbf->new('123.456'),'123.5'); # with A +${"$mbf\::accuracy"} = undef; +${"$mbf\::precision"} = -1; +ok ($mbf->new('123.456'),'123.5'); # with P from MBF, not MBI! + +${"$mbf\::precision"} = undef; # reset + +############################################################################### +# see if MBI leaves MBF's private parts alone + +${"$mbi\::precision"} = undef; ${"$mbf\::precision"} = undef; +${"$mbi\::accuracy"} = 4; ${"$mbf\::accuracy"} = undef; +ok (Math::BigFloat->new('123.456'),'123.456'); +${"$mbi\::accuracy"} = undef; # reset + +############################################################################### +# see if setting accuracy/precision actually rounds the number + +$x = $mbf->new('123.456'); $x->accuracy(4); ok ($x,'123.5'); +$x = $mbf->new('123.456'); $x->precision(-2); ok ($x,'123.46'); + +$x = $mbi->new(123456); $x->accuracy(4); ok ($x,123500); +$x = $mbi->new(123456); $x->precision(2); ok ($x,123500); + +############################################################################### +# test actual rounding via round() + +$x = $mbf->new('123.456'); +ok ($x->copy()->round(5),'123.46'); +ok ($x->copy()->round(4),'123.5'); +ok ($x->copy()->round(5,2),'NaN'); +ok ($x->copy()->round(undef,-2),'123.46'); +ok ($x->copy()->round(undef,2),100); + +$x = $mbi->new('123'); +ok ($x->round(5,2),'NaN'); + +$x = $mbf->new('123.45000'); +ok ($x->copy()->round(undef,-1,'odd'),'123.5'); + +# see if rounding is 'sticky' +$x = $mbf->new('123.4567'); +$y = $x->copy()->bround(); # no-op since nowhere A or P defined + +ok ($y,123.4567); +$y = $x->copy()->round(5); +ok ($y->accuracy(),5); +ok_undef ($y->precision()); # A has precedence, so P still unset +$y = $x->copy()->round(undef,2); +ok ($y->precision(),2); +ok_undef ($y->accuracy()); # P has precedence, so A still unset + +# see if setting A clears P and vice versa +$x = $mbf->new('123.4567'); +ok ($x,'123.4567'); +ok ($x->accuracy(4),4); +ok ($x->precision(-2),-2); # clear A +ok_undef ($x->accuracy()); + +$x = $mbf->new('123.4567'); +ok ($x,'123.4567'); +ok ($x->precision(-2),-2); +ok ($x->accuracy(4),4); # clear P +ok_undef ($x->precision()); + +# does copy work? +$x = $mbf->new(123.456); $x->accuracy(4); $x->precision(2); +$z = $x->copy(); ok_undef ($z->accuracy(),undef); ok ($z->precision(),2); + +# does accuracy()/precision work on zeros? +foreach my $class ($mbi,$mbf) + { + $x = $class->bzero(); $x->accuracy(5); ok ($x->{_a},5); + $x = $class->bzero(); $x->precision(5); ok ($x->{_p},5); + $x = $class->new(0); $x->accuracy(5); ok ($x->{_a},5); + $x = $class->new(0); $x->precision(5); ok ($x->{_p},5); + + $x = $class->bzero(); $x->round(5); ok ($x->{_a},5); + $x = $class->bzero(); $x->round(undef,5); ok ($x->{_p},5); + $x = $class->new(0); $x->round(5); ok ($x->{_a},5); + $x = $class->new(0); $x->round(undef,5); ok ($x->{_p},5); + + # see if trying to increasing A in bzero() doesn't do something + $x = $class->bzero(); $x->{_a} = 3; $x->round(5); ok ($x->{_a},3); + } + +############################################################################### +# test wether operations round properly afterwards +# These tests are not complete, since they do not excercise every "return" +# statement in the op's. But heh, it's better than nothing... + +$x = $mbf->new('123.456'); +$y = $mbf->new('654.321'); +$x->{_a} = 5; # $x->accuracy(5) would round $x straightaway +$y->{_a} = 4; # $y->accuracy(4) would round $x straightaway + +$z = $x + $y; ok ($z,'777.8'); +$z = $y - $x; ok ($z,'530.9'); +$z = $y * $x; ok ($z,'80780'); +$z = $x ** 2; ok ($z,'15241'); +$z = $x * $x; ok ($z,'15241'); + +# not: $z = -$x; ok ($z,'-123.46'); ok ($x,'123.456'); +$z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62); +$x = $mbf->new(123456); $x->{_a} = 4; +$z = $x->copy; $z++; ok ($z,123500); + +$x = $mbi->new(123456); +$y = $mbi->new(654321); +$x->{_a} = 5; # $x->accuracy(5) would round $x straightaway +$y->{_a} = 4; # $y->accuracy(4) would round $x straightaway + +$z = $x + $y; ok ($z,777800); +$z = $y - $x; ok ($z,530900); +$z = $y * $x; ok ($z,80780000000); +$z = $x ** 2; ok ($z,15241000000); +# not yet: $z = -$x; ok ($z,-123460); ok ($x,123456); +$z = $x->copy; $z++; ok ($z,123460); +$z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62000); + +$x = $mbi->new(123400); $x->{_a} = 4; +ok ($x->bnot(),-123400); # not -1234001 + +# both babs() and bneg() don't need to round, since the input will already +# be rounded (either as $x or via new($string)), and they don't change the +# value. The two tests below peek at this by using _a (illegally) directly +$x = $mbi->new(-123401); $x->{_a} = 4; ok ($x->babs(),123401); +$x = $mbi->new(-123401); $x->{_a} = 4; ok ($x->bneg(),123401); + +# test fdiv rounding to A and R (bug in v1.48 and maybe earlier versions) +$mbf->round_mode('even'); +$x = $mbf->new('740.7')->fdiv('6',4,undef,'zero'); ok ($x,'123.4'); + +############################################################################### +# test mixed arguments + +$x = $mbf->new(10); +$u = $mbf->new(2.5); +$y = $mbi->new(2); + +$z = $x + $y; ok ($z,12); ok (ref($z),$mbf); +$z = $x / $y; ok ($z,5); ok (ref($z),$mbf); +$z = $u * $y; ok ($z,5); ok (ref($z),$mbf); + +$y = $mbi->new(12345); +$z = $u->copy()->bmul($y,2,undef,'odd'); ok ($z,31000); +$z = $u->copy()->bmul($y,3,undef,'odd'); ok ($z,30900); +$z = $u->copy()->bmul($y,undef,0,'odd'); ok ($z,30863); +$z = $u->copy()->bmul($y,undef,1,'odd'); ok ($z,30860); +$z = $u->copy()->bmul($y,undef,-1,'odd'); ok ($z,30862.5); + +# breakage: +# $z = $y->copy()->bmul($u,2,0,'odd'); ok ($z,31000); +# $z = $y * $u; ok ($z,5); ok (ref($z),$mbi); +# $z = $y + $x; ok ($z,12); ok (ref($z),$mbi); +# $z = $y / $x; ok ($z,0); ok (ref($z),$mbi); + +############################################################################### +# rounding in bdiv with fallback and already set A or P + +${"$mbf\::accuracy"} = undef; +${"$mbf\::precision"} = undef; +${"$mbf\::div_scale"} = 40; + +$x = $mbf->new(10); $x->{_a} = 4; +ok ($x->bdiv(3),'3.333'); +ok ($x->{_a},4); # set's it since no fallback + +$x = $mbf->new(10); $x->{_a} = 4; $y = $mbf->new(3); +ok ($x->bdiv($y),'3.333'); +ok ($x->{_a},4); # set's it since no fallback + +# rounding to P of x +$x = $mbf->new(10); $x->{_p} = -2; +ok ($x->bdiv(3),'3.33'); + +# round in div with requested P +$x = $mbf->new(10); +ok ($x->bdiv(3,undef,-2),'3.33'); + +# round in div with requested P greater than fallback +${"$mbf\::div_scale"} = 5; +$x = $mbf->new(10); +ok ($x->bdiv(3,undef,-8),'3.33333333'); +${"$mbf\::div_scale"} = 40; + +$x = $mbf->new(10); $y = $mbf->new(3); $y->{_a} = 4; +ok ($x->bdiv($y),'3.333'); +ok ($x->{_a},4); ok ($y->{_a},4); # set's it since no fallback +ok_undef ($x->{_p}); ok_undef ($y->{_p}); + +# rounding to P of y +$x = $mbf->new(10); $y = $mbf->new(3); $y->{_p} = -2; +ok ($x->bdiv($y),'3.33'); +ok ($x->{_p},-2); + ok ($y->{_p},-2); +ok_undef ($x->{_a}); ok_undef ($y->{_a}); + +############################################################################### +# test whether bround(-n) fails in MBF (undocumented in MBI) +eval { $x = $mbf->new(1); $x->bround(-2); }; +ok ($@ =~ /^bround\(\) needs positive accuracy/,1); + +# test whether rounding to higher accuracy is no-op +$x = $mbf->new(1); $x->{_a} = 4; +ok ($x,'1.000'); +$x->bround(6); # must be no-op +ok ($x->{_a},4); +ok ($x,'1.000'); + +$x = $mbi->new(1230); $x->{_a} = 3; +ok ($x,'1230'); +$x->bround(6); # must be no-op +ok ($x->{_a},3); +ok ($x,'1230'); + +# bround(n) should set _a +$x->bround(2); # smaller works +ok ($x,'1200'); +ok ($x->{_a},2); + +# bround(-n) is undocumented and only used by MBF +# bround(-n) should set _a +$x = $mbi->new(12345); +$x->bround(-1); +ok ($x,'12300'); +ok ($x->{_a},4); + +# bround(-n) should set _a +$x = $mbi->new(12345); +$x->bround(-2); +ok ($x,'12000'); +ok ($x->{_a},3); + +# bround(-n) should set _a +$x = $mbi->new(12345); $x->{_a} = 5; +$x->bround(-3); +ok ($x,'10000'); +ok ($x->{_a},2); + +# bround(-n) should set _a +$x = $mbi->new(12345); $x->{_a} = 5; +$x->bround(-4); +ok ($x,'0'); +ok ($x->{_a},1); + +# bround(-n) should be noop if n too big +$x = $mbi->new(12345); +$x->bround(-5); +ok ($x,'0'); # scale to "big" => 0 +ok ($x->{_a},0); + +# bround(-n) should be noop if n too big +$x = $mbi->new(54321); +$x->bround(-5); +ok ($x,'100000'); # used by MBF to round 0.0054321 at 0.0_6_00000 +ok ($x->{_a},0); + +# bround(-n) should be noop if n too big +$x = $mbi->new(54321); $x->{_a} = 5; +$x->bround(-6); +ok ($x,'100000'); # no-op +ok ($x->{_a},0); + +# bround(n) should set _a +$x = $mbi->new(12345); $x->{_a} = 5; +$x->bround(5); # must be no-op +ok ($x,'12345'); +ok ($x->{_a},5); + +# bround(n) should set _a +$x = $mbi->new(12345); $x->{_a} = 5; +$x->bround(6); # must be no-op +ok ($x,'12345'); + +$x = $mbf->new('0.0061'); $x->bfround(-2); +ok ($x,'0.01'); + +# MBI::bfround should clear A for negative P +$x = $mbi->new('1234'); $x->accuracy(3); $x->bfround(-2); +ok_undef ($x->{_a}); + +############################################################################### +# rounding with already set precision/accuracy + +$x = $mbf->new(1); $x->{_p} = -5; +ok ($x,'1.00000'); + +# further rounding donw +ok ($x->bfround(-2),'1.00'); +ok ($x->{_p},-2); + +$x = $mbf->new(12345); $x->{_a} = 5; +ok ($x->bround(2),'12000'); +ok ($x->{_a},2); + +$x = $mbf->new('1.2345'); $x->{_a} = 5; +ok ($x->bround(2),'1.2'); +ok ($x->{_a},2); + +# mantissa/exponent format and A/P +$x = $mbf->new('12345.678'); $x->accuracy(4); +ok ($x,'12350'); ok ($x->{_a},4); ok_undef ($x->{_p}); +ok_undef ($x->{_m}->{_a}); ok_undef ($x->{_e}->{_a}); +ok_undef ($x->{_m}->{_p}); ok_undef ($x->{_e}->{_p}); + +# check for no A/P in case of fallback +# result +$x = $mbf->new(100) / 3; +ok_undef ($x->{_a}); ok_undef ($x->{_p}); + +# result & reminder +$x = $mbf->new(100) / 3; ($x,$y) = $x->bdiv(3); +ok_undef ($x->{_a}); ok_undef ($x->{_p}); +ok_undef ($y->{_a}); ok_undef ($y->{_p}); + +############################################################################### +# math with two numbers with differen A and P + +$x = $mbf->new(12345); $x->accuracy(4); # '12340' +$y = $mbf->new(12345); $y->accuracy(2); # '12000' +ok ($x+$y,24000); # 12340+12000=> 24340 => 24000 + +$x = $mbf->new(54321); $x->accuracy(4); # '12340' +$y = $mbf->new(12345); $y->accuracy(3); # '12000' +ok ($x-$y,42000); # 54320+12300=> 42020 => 42000 + +$x = $mbf->new('1.2345'); $x->precision(-2); # '1.23' +$y = $mbf->new('1.2345'); $y->precision(-4); # '1.2345' +ok ($x+$y,'2.46'); # 1.2345+1.2300=> 2.4645 => 2.46 + +############################################################################### +# round should find and use proper class + +#$x = Foo->new(); +#ok ($x->round($Foo::accuracy),'a' x $Foo::accuracy); +#ok ($x->round(undef,$Foo::precision),'p' x $Foo::precision); +#ok ($x->bfround($Foo::precision),'p' x $Foo::precision); +#ok ($x->bround($Foo::accuracy),'a' x $Foo::accuracy); + +############################################################################### +# find out whether _find_round_parameters is doing what's it's supposed to do + +${"$mbi\::accuracy"} = undef; +${"$mbi\::precision"} = undef; +${"$mbi\::div_scale"} = 40; +${"$mbi\::round_mode"} = 'odd'; + +$x = $mbi->new(123); +my @params = $x->_find_round_parameters(); +ok (scalar @params,1); # nothing to round + +@params = $x->_find_round_parameters(1); +ok (scalar @params,4); # a=1 +ok ($params[0],$x); # self +ok ($params[1],1); # a +ok_undef ($params[2]); # p +ok ($params[3],'odd'); # round_mode + +@params = $x->_find_round_parameters(undef,2); +ok (scalar @params,4); # p=2 +ok ($params[0],$x); # self +ok_undef ($params[1]); # a +ok ($params[2],2); # p +ok ($params[3],'odd'); # round_mode + +eval { @params = $x->_find_round_parameters(undef,2,'foo'); }; +ok ($@ =~ /^Unknown round mode 'foo'/,1); + +@params = $x->_find_round_parameters(undef,2,'+inf'); +ok (scalar @params,4); # p=2 +ok ($params[0],$x); # self +ok_undef ($params[1]); # a +ok ($params[2],2); # p +ok ($params[3],'+inf'); # round_mode + +@params = $x->_find_round_parameters(2,-2,'+inf'); +ok (scalar @params,1); # error, A and P defined +ok ($params[0],$x); # self + +${"$mbi\::accuracy"} = 1; +@params = $x->_find_round_parameters(undef,-2); +ok (scalar @params,1); # error, A and P defined +ok ($params[0],$x); # self + +${"$mbi\::accuracy"} = undef; +${"$mbi\::precision"} = 1; +@params = $x->_find_round_parameters(1,undef); +ok (scalar @params,1); # error, A and P defined +ok ($params[0],$x); # self + +${"$mbi\::precision"} = undef; # reset + +############################################################################### +# test whether bone/bzero take additional A & P, or reset it etc + +foreach my $class ($mbi,$mbf) + { + $x = $class->new(2)->bzero(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); + $x = $class->new(2)->bone(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); + $x = $class->new(2)->binf(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); + $x = $class->new(2)->bnan(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); + + $x = $class->new(2); $x->{_a} = 1; $x->{_p} = 2; $x->bnan(); + ok_undef ($x->{_a}); ok_undef ($x->{_p}); + $x = $class->new(2); $x->{_a} = 1; $x->{_p} = 2; $x->binf(); + ok_undef ($x->{_a}); ok_undef ($x->{_p}); + + $x = $class->new(2,1); ok ($x->{_a},1); ok_undef ($x->{_p}); + $x = $class->new(2,undef,1); ok_undef ($x->{_a}); ok ($x->{_p},1); + + $x = $class->new(2,1)->bzero(); ok ($x->{_a},1); ok_undef ($x->{_p}); + $x = $class->new(2,undef,1)->bzero(); ok_undef ($x->{_a}); ok ($x->{_p},1); + + $x = $class->new(2,1)->bone(); ok ($x->{_a},1); ok_undef ($x->{_p}); + $x = $class->new(2,undef,1)->bone(); ok_undef ($x->{_a}); ok ($x->{_p},1); + } + +############################################################################### +# check whether mixing A and P creates a NaN + +# new with set accuracy/precision and with parameters + +foreach my $class ($mbi,$mbf) + { + ok ($class->new(123,4,-3),'NaN'); # with parameters + ${"$class\::accuracy"} = 42; + ${"$class\::precision"} = 2; + ok ($class->new(123),'NaN'); # with globals + ${"$class\::accuracy"} = undef; + ${"$class\::precision"} = undef; + } + +# binary ops +foreach my $class ($mbi,$mbf) + { + foreach (qw/add sub mul pow mod/) + #foreach (qw/add sub mul div pow mod/) + { + my $try = "my \$x = $class->new(1234); \$x->accuracy(5); "; + $try .= "my \$y = $class->new(12); \$y->precision(-3); "; + $try .= "\$x->b$_(\$y);"; + $rc = eval $try; + print "# Tried: '$try'\n" if !ok ($rc, 'NaN'); + } + } + +# unary ops +foreach (qw/new bsqrt/) + { + my $try = 'my $x = $mbi->$_(1234,5,-3); '; + $rc = eval $try; + print "# Tried: '$try'\n" if !ok ($rc, 'NaN'); + } + +############################################################################### +# test whether shortcuts returning zero/one preserve A and P + +my ($ans1,$f,$a,$p,$xp,$yp,$xa,$ya,$try,$ans,@args); +my $CALC = Math::BigInt::_core_lib(); +while () + { + chop; + next if /^\s*(#|$)/; # skip comments and empty lines + if (s/^&//) + { + $f = $_; next; # function + } + @args = split(/:/,$_,99); + my $ans = pop(@args); + + ($x,$xa,$xp) = split (/,/,$args[0]); + $xa = $xa || ''; $xp = $xp || ''; + $try = "\$x = $mbi->new('$x'); "; + $try .= "\$x->accuracy($xa); " if $xa ne ''; + $try .= "\$x->precision($xp); " if $xp ne ''; + + ($y,$ya,$yp) = split (/,/,$args[1]); + $ya = $ya || ''; $yp = $yp || ''; + $try .= "\$y = $mbi->new('$y'); "; + $try .= "\$y->accuracy($ya); " if $ya ne ''; + $try .= "\$y->precision($yp); " if $yp ne ''; + + $try .= "\$x->$f(\$y);"; + + # print "trying $try\n"; + $rc = eval $try; + # convert hex/binary targets to decimal + if ($ans =~ /^(0x0x|0b0b)/) + { + $ans =~ s/^0[xb]//; + $ans = $mbi->new($ans)->bstr(); + } + print "# Tried: '$try'\n" if !ok ($rc, $ans); + # check internal state of number objects + is_valid($rc,$f) if ref $rc; + + # now check whether A and P are set correctly + # only one of $a or $p will be set (no crossing here) + $a = $xa || $ya; $p = $xp || $yp; + + # print "Check a=$a p=$p\n"; + print "# Tried: '$try'\n"; + ok ($x->{_a}, $a) && ok_undef ($x->{_p}) if $a ne ''; + ok ($x->{_p}, $p) && ok_undef ($x->{_a}) if $p ne ''; + } + +# all done +1; + +############################################################################### +############################################################################### +# Perl 5.005 does not like ok ($x,undef) + +sub ok_undef + { + my $x = shift; + + ok (1,1) and return if !defined $x; + ok ($x,'undef'); + print "# Called from ",join(' ',caller()),"\n"; + } + +############################################################################### +# sub to check validity of a BigInt internally, to ensure that no op leaves a +# number object in an invalid state (f.i. "-0") + +sub is_valid + { + my ($x,$f) = @_; + + my $e = 0; # error? + # ok as reference? + $e = 'Not a reference' if !ref($x); + + # has ok sign? + $e = "Illegal sign $x->{sign} (expected: '+', '-', '-inf', '+inf' or 'NaN'" + if $e eq '0' && $x->{sign} !~ /^(\+|-|\+inf|-inf|NaN)$/; + + $e = "-0 is invalid!" if $e ne '0' && $x->{sign} eq '-' && $x == 0; + $e = $CALC->_check($x->{value}) if $e eq '0'; + + # test done, see if error did crop up + ok (1,1), return if ($e eq '0'); + + ok (1,$e." after op '$f'"); + } + +# format is: +# x,A,P:x,A,P:result +# 123,,3 means 123 with precision 3 (A is undef) +# the A or P of the result is calculated automatically +__DATA__ +&badd +# bsub uses badd anyway, so it should be right +123,,:123,,:246 +123,3,:0,,:123 +123,,-3:0,,:123 +123,,:0,3,:123 +123,,:0,,-3:123 +&bmul +123,,:1,,:123 +123,3,:0,,:0 +123,,-3:0,,:0 +123,,:0,3,:0 +123,,:0,,-3:0 +123,3,:1,,:123 +123,,-3:1,,:123 +123,,:1,3,:123 +123,,:1,,-3:123 +1,3,:123,,:123 +1,,-3:123,,:123 +1,,:123,3,:123 +1,,:123,,-3:123 +&bdiv +123,,:1,,:123 +123,4,:1,,:123 +123,,:1,4,:123 +123,,:1,,-4:123 +123,,-4:1,,:123 +1,4,:123,,:0 +1,,:123,4,:0 +1,,:123,,-4:0 +1,,-4:123,,:0 diff --git a/lib/Math/BigInt/t/mbimbf.t b/lib/Math/BigInt/t/mbimbf.t index 976bb9b..af3e4cf 100644 --- a/lib/Math/BigInt/t/mbimbf.t +++ b/lib/Math/BigInt/t/mbimbf.t @@ -3,576 +3,70 @@ # test rounding, accuracy, precicion and fallback, round_mode and mixing # of classes -# Make sure you always quote any bare floating-point values, lest 123.46 will -# be stringified to 123.4599999999 due to limited float prevision. - use strict; use Test; -BEGIN +BEGIN { $| = 1; - chdir 't' if -d 't'; - unshift @INC, '../lib'; # for running manually - plan tests => 260; - } - -# for finding out whether round finds correct class -package Foo; - -use Math::BigInt; -use vars qw/@ISA $precision $accuracy $div_scale $round_mode/; -@ISA = qw/Math::BigInt/; - -$precision = 6; -$accuracy = 8; -$div_scale = 5; -$round_mode = 'odd'; - -sub new - { - my $class = shift; - my $self = { _a => undef, _p => undef, value => 5 }; - bless $self, $class; - } - -sub bstr - { - my $self = shift; - - return "$self->{value}"; - } - -# these will be called with the rounding precision or accuracy, depending on -# class -sub bround - { - my ($self,$a,$r) = @_; - $self->{value} = 'a' x $a; - return $self; - } - -sub bnorm - { - my $self = shift; - return $self; + # to locate the testing files + my $location = $0; $location =~ s/mbimbf.t//i; + if ($ENV{PERL_CORE}) + { + @INC = qw(../lib); # testing with the core distribution + } + else + { + unshift @INC, '../lib'; # for testing manually + } + if (-d 't') + { + chdir 't'; + require File::Spec; + unshift @INC, File::Spec->catdir(File::Spec->updir, $location); + } + else + { + unshift @INC, $location; + } + print "# INC = @INC\n"; + + plan tests => 428 + + 8; # own test } -sub bfround - { - my ($self,$p,$r) = @_; - $self->{value} = 'p' x $p; - return $self; - } +use Math::BigInt 1.49; +use Math::BigFloat 1.26; -package main; +use vars qw/$mbi $mbf/; -use Math::BigInt; -use Math::BigFloat; +$mbi = 'Math::BigInt'; +$mbf = 'Math::BigFloat'; -my ($x,$y,$z,$u); +require 'mbimbf.inc'; -############################################################################### -# test defaults and set/get +# some tests that won't work with subclasses, since the things are only +# garantied in the Math::BigInt/BigFloat (unless subclass chooses to support +# this) -ok_undef ($Math::BigInt::accuracy); -ok_undef ($Math::BigInt::precision); -ok_undef (Math::BigInt::accuracy()); -ok_undef (Math::BigInt::precision()); -ok_undef (Math::BigInt->accuracy()); -ok_undef (Math::BigInt->precision()); -ok ($Math::BigInt::div_scale,40); -ok (Math::BigInt::div_scale(),40); -ok ($Math::BigInt::round_mode,'even'); -ok (Math::BigInt::round_mode(),'even'); -ok (Math::BigInt->round_mode(),'even'); +Math::BigInt->round_mode('even'); # reset for tests +Math::BigFloat->round_mode('even'); # reset for tests -ok_undef ($Math::BigFloat::accuracy); -ok_undef ($Math::BigFloat::precision); -ok_undef (Math::BigFloat::accuracy()); -ok_undef (Math::BigFloat::accuracy()); -ok_undef (Math::BigFloat->precision()); -ok_undef (Math::BigFloat->precision()); -ok ($Math::BigFloat::div_scale,40); -ok (Math::BigFloat::div_scale(),40); -ok ($Math::BigFloat::round_mode,'even'); -ok (Math::BigFloat::round_mode(),'even'); -ok (Math::BigFloat->round_mode(),'even'); - -# old way ok ($Math::BigInt::rnd_mode,'even'); ok ($Math::BigFloat::rnd_mode,'even'); -$x = eval 'Math::BigInt->round_mode("huhmbi");'; +my $x = eval '$mbi->round_mode("huhmbi");'; ok ($@ =~ /^Unknown round mode huhmbi at/); -$x = eval 'Math::BigFloat->round_mode("huhmbf");'; +$x = eval '$mbf->round_mode("huhmbf");'; ok ($@ =~ /^Unknown round mode huhmbf at/); # old way (now with test for validity) $x = eval '$Math::BigInt::rnd_mode = "huhmbi";'; ok ($@ =~ /^Unknown round mode huhmbi at/); -$x = eval '$Math::BigFloat::rnd_mode = "huhmbi";'; -ok ($@ =~ /^Unknown round mode huhmbi at/); +$x = eval '$Math::BigFloat::rnd_mode = "huhmbf";'; +ok ($@ =~ /^Unknown round mode huhmbf at/); # see if accessor also changes old variable -Math::BigInt->round_mode('odd'); -ok ($Math::BigInt::rnd_mode,'odd'); -Math::BigFloat->round_mode('odd'); -ok ($Math::BigFloat::rnd_mode,'odd'); - -Math::BigInt->round_mode('even'); -Math::BigFloat->round_mode('even'); - -# accessors -foreach my $class (qw/Math::BigInt Math::BigFloat/) - { - ok_undef ($class->accuracy()); - ok_undef ($class->precision()); - ok ($class->round_mode(),'even'); - ok ($class->div_scale(),40); - - ok ($class->div_scale(20),20); - $class->div_scale(40); ok ($class->div_scale(),40); - - ok ($class->round_mode('odd'),'odd'); - $class->round_mode('even'); ok ($class->round_mode(),'even'); - - ok ($class->accuracy(2),2); - $class->accuracy(3); ok ($class->accuracy(),3); - ok_undef ($class->accuracy(undef)); - - ok ($class->precision(2),2); - ok ($class->precision(-2),-2); - $class->precision(3); ok ($class->precision(),3); - ok_undef ($class->precision(undef)); - } - -# accuracy -foreach (qw/5 42 -1 0/) - { - ok ($Math::BigFloat::accuracy = $_,$_); - ok ($Math::BigInt::accuracy = $_,$_); - } -ok_undef ($Math::BigFloat::accuracy = undef); -ok_undef ($Math::BigInt::accuracy = undef); - -# precision -foreach (qw/5 42 -1 0/) - { - ok ($Math::BigFloat::precision = $_,$_); - ok ($Math::BigInt::precision = $_,$_); - } -ok_undef ($Math::BigFloat::precision = undef); -ok_undef ($Math::BigInt::precision = undef); - -# fallback -foreach (qw/5 42 1/) - { - ok ($Math::BigFloat::div_scale = $_,$_); - ok ($Math::BigInt::div_scale = $_,$_); - } -# illegal values are possible for fallback due to no accessor - -# round_mode -foreach (qw/odd even zero trunc +inf -inf/) - { - ok ($Math::BigFloat::round_mode = $_,$_); - ok ($Math::BigInt::round_mode = $_,$_); - } -$Math::BigFloat::round_mode = 'zero'; -ok ($Math::BigFloat::round_mode,'zero'); -ok ($Math::BigInt::round_mode,'-inf'); # from above - -$Math::BigInt::accuracy = undef; -$Math::BigInt::precision = undef; -# local copies -$x = Math::BigFloat->new('123.456'); -ok_undef ($x->accuracy()); -ok ($x->accuracy(5),5); -ok_undef ($x->accuracy(undef),undef); -ok_undef ($x->precision()); -ok ($x->precision(5),5); -ok_undef ($x->precision(undef),undef); - -# see if MBF changes MBIs values -ok ($Math::BigInt::accuracy = 42,42); -ok ($Math::BigFloat::accuracy = 64,64); -ok ($Math::BigInt::accuracy,42); # should be still 42 -ok ($Math::BigFloat::accuracy,64); # should be still 64 - -############################################################################### -# see if creating a number under set A or P will round it - -$Math::BigInt::accuracy = 4; -$Math::BigInt::precision = 3; - -ok (Math::BigInt->new(123456),123500); # with A -$Math::BigInt::accuracy = undef; -ok (Math::BigInt->new(123456),123000); # with P - -$Math::BigFloat::accuracy = 4; -$Math::BigFloat::precision = -1; -$Math::BigInt::precision = undef; - -ok (Math::BigFloat->new('123.456'),'123.5'); # with A -$Math::BigFloat::accuracy = undef; -ok (Math::BigFloat->new('123.456'),'123.5'); # with P from MBF, not MBI! - -$Math::BigFloat::precision = undef; - -############################################################################### -# see if setting accuracy/precision actually rounds the number - -$x = Math::BigFloat->new('123.456'); $x->accuracy(4); ok ($x,'123.5'); -$x = Math::BigFloat->new('123.456'); $x->precision(-2); ok ($x,'123.46'); - -$x = Math::BigInt->new(123456); $x->accuracy(4); ok ($x,123500); -$x = Math::BigInt->new(123456); $x->precision(2); ok ($x,123500); - -############################################################################### -# test actual rounding via round() - -$x = Math::BigFloat->new('123.456'); -ok ($x->copy()->round(5,2),'123.46'); -ok ($x->copy()->round(4,2),'123.5'); -ok ($x->copy()->round(undef,-2),'123.46'); -ok ($x->copy()->round(undef,2),100); - -$x = Math::BigFloat->new('123.45000'); -ok ($x->copy()->round(undef,-1,'odd'),'123.5'); - -# see if rounding is 'sticky' -$x = Math::BigFloat->new('123.4567'); -$y = $x->copy()->bround(); # no-op since nowhere A or P defined - -ok ($y,123.4567); -$y = $x->copy()->round(5,2); -ok ($y->accuracy(),5); -ok_undef ($y->precision()); # A has precedence, so P still unset -$y = $x->copy()->round(undef,2); -ok ($y->precision(),2); -ok_undef ($y->accuracy()); # P has precedence, so A still unset - -# see if setting A clears P and vice versa -$x = Math::BigFloat->new('123.4567'); -ok ($x,'123.4567'); -ok ($x->accuracy(4),4); -ok ($x->precision(-2),-2); # clear A -ok_undef ($x->accuracy()); - -$x = Math::BigFloat->new('123.4567'); -ok ($x,'123.4567'); -ok ($x->precision(-2),-2); -ok ($x->accuracy(4),4); # clear P -ok_undef ($x->precision()); - -# does copy work? -$x = Math::BigFloat->new(123.456); $x->accuracy(4); $x->precision(2); -$z = $x->copy(); ok_undef ($z->accuracy(),undef); ok ($z->precision(),2); - -############################################################################### -# test wether operations round properly afterwards -# These tests are not complete, since they do not excercise every "return" -# statement in the op's. But heh, it's better than nothing... - -$x = Math::BigFloat->new('123.456'); -$y = Math::BigFloat->new('654.321'); -$x->{_a} = 5; # $x->accuracy(5) would round $x straightaway -$y->{_a} = 4; # $y->accuracy(4) would round $x straightaway - -$z = $x + $y; ok ($z,'777.8'); -$z = $y - $x; ok ($z,'530.9'); -$z = $y * $x; ok ($z,'80780'); -$z = $x ** 2; ok ($z,'15241'); -$z = $x * $x; ok ($z,'15241'); - -# not: $z = -$x; ok ($z,'-123.46'); ok ($x,'123.456'); -$z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62); -$x = Math::BigFloat->new(123456); $x->{_a} = 4; -$z = $x->copy; $z++; ok ($z,123500); - -$x = Math::BigInt->new(123456); -$y = Math::BigInt->new(654321); -$x->{_a} = 5; # $x->accuracy(5) would round $x straightaway -$y->{_a} = 4; # $y->accuracy(4) would round $x straightaway - -$z = $x + $y; ok ($z,777800); -$z = $y - $x; ok ($z,530900); -$z = $y * $x; ok ($z,80780000000); -$z = $x ** 2; ok ($z,15241000000); -# not yet: $z = -$x; ok ($z,-123460); ok ($x,123456); -$z = $x->copy; $z++; ok ($z,123460); -$z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62000); - -$x = Math::BigInt->new(123400); $x->{_a} = 4; -ok ($x->bnot(),-123400); # not -1234001 - -# both babs() and bneg() don't need to round, since the input will already -# be rounded (either as $x or via new($string)), and they don't change the -# value -# The two tests below peek at this by using _a illegally -$x = Math::BigInt->new(-123401); $x->{_a} = 4; -ok ($x->babs(),123401); -$x = Math::BigInt->new(-123401); $x->{_a} = 4; -ok ($x->bneg(),123401); - -############################################################################### -# test mixed arguments - -$x = Math::BigFloat->new(10); -$u = Math::BigFloat->new(2.5); -$y = Math::BigInt->new(2); - -$z = $x + $y; ok ($z,12); ok (ref($z),'Math::BigFloat'); -$z = $x / $y; ok ($z,5); ok (ref($z),'Math::BigFloat'); -$z = $u * $y; ok ($z,5); ok (ref($z),'Math::BigFloat'); - -$y = Math::BigInt->new(12345); -$z = $u->copy()->bmul($y,2,0,'odd'); ok ($z,31000); -$z = $u->copy()->bmul($y,3,0,'odd'); ok ($z,30900); -$z = $u->copy()->bmul($y,undef,0,'odd'); ok ($z,30863); -$z = $u->copy()->bmul($y,undef,1,'odd'); ok ($z,30860); -$z = $u->copy()->bmul($y,undef,-1,'odd'); ok ($z,30862.5); - -# breakage: -# $z = $y->copy()->bmul($u,2,0,'odd'); ok ($z,31000); -# $z = $y * $u; ok ($z,5); ok (ref($z),'Math::BigInt'); -# $z = $y + $x; ok ($z,12); ok (ref($z),'Math::BigInt'); -# $z = $y / $x; ok ($z,0); ok (ref($z),'Math::BigInt'); - -############################################################################### -# rounding in bdiv with fallback and already set A or P - -$Math::BigFloat::accuracy = undef; -$Math::BigFloat::precision = undef; -$Math::BigFloat::div_scale = 40; - -$x = Math::BigFloat->new(10); $x->{_a} = 4; -ok ($x->bdiv(3),'3.333'); -ok ($x->{_a},4); # set's it since no fallback - -$x = Math::BigFloat->new(10); $x->{_a} = 4; $y = Math::BigFloat->new(3); -ok ($x->bdiv($y),'3.333'); -ok ($x->{_a},4); # set's it since no fallback - -# rounding to P of x -$x = Math::BigFloat->new(10); $x->{_p} = -2; -ok ($x->bdiv(3),'3.33'); - -# round in div with requested P -$x = Math::BigFloat->new(10); -ok ($x->bdiv(3,undef,-2),'3.33'); - -# round in div with requested P greater than fallback -$Math::BigFloat::div_scale = 5; -$x = Math::BigFloat->new(10); -ok ($x->bdiv(3,undef,-8),'3.33333333'); -$Math::BigFloat::div_scale = 40; - -$x = Math::BigFloat->new(10); $y = Math::BigFloat->new(3); $y->{_a} = 4; -ok ($x->bdiv($y),'3.333'); -ok ($x->{_a},4); ok ($y->{_a},4); # set's it since no fallback -ok_undef ($x->{_p}); ok_undef ($y->{_p}); - -# rounding to P of y -$x = Math::BigFloat->new(10); $y = Math::BigFloat->new(3); $y->{_p} = -2; -ok ($x->bdiv($y),'3.33'); -ok ($x->{_p},-2); - ok ($y->{_p},-2); -ok_undef ($x->{_a}); ok_undef ($y->{_a}); - -############################################################################### -# test whether bround(-n) fails in MBF (undocumented in MBI) -eval { $x = Math::BigFloat->new(1); $x->bround(-2); }; -ok ($@ =~ /^bround\(\) needs positive accuracy/,1); - -# test whether rounding to higher accuracy is no-op -$x = Math::BigFloat->new(1); $x->{_a} = 4; -ok ($x,'1.000'); -$x->bround(6); # must be no-op -ok ($x->{_a},4); -ok ($x,'1.000'); - -$x = Math::BigInt->new(1230); $x->{_a} = 3; -ok ($x,'1230'); -$x->bround(6); # must be no-op -ok ($x->{_a},3); -ok ($x,'1230'); - -# bround(n) should set _a -$x->bround(2); # smaller works -ok ($x,'1200'); -ok ($x->{_a},2); - -# bround(-n) is undocumented and only used by MBF -# bround(-n) should set _a -$x = Math::BigInt->new(12345); -$x->bround(-1); -ok ($x,'12300'); -ok ($x->{_a},4); - -# bround(-n) should set _a -$x = Math::BigInt->new(12345); -$x->bround(-2); -ok ($x,'12000'); -ok ($x->{_a},3); - -# bround(-n) should set _a -$x = Math::BigInt->new(12345); $x->{_a} = 5; -$x->bround(-3); -ok ($x,'10000'); -ok ($x->{_a},2); - -# bround(-n) should set _a -$x = Math::BigInt->new(12345); $x->{_a} = 5; -$x->bround(-4); -ok ($x,'00000'); -ok ($x->{_a},1); - -# bround(-n) should be noop if n too big -$x = Math::BigInt->new(12345); -$x->bround(-5); -ok ($x,'0'); # scale to "big" => 0 -ok ($x->{_a},0); - -# bround(-n) should be noop if n too big -$x = Math::BigInt->new(54321); -$x->bround(-5); -ok ($x,'100000'); # used by MBF to round 0.0054321 at 0.0_6_00000 -ok ($x->{_a},0); - -# bround(-n) should be noop if n too big -$x = Math::BigInt->new(54321); $x->{_a} = 5; -$x->bround(-6); -ok ($x,'100000'); # no-op -ok ($x->{_a},0); - -# bround(n) should set _a -$x = Math::BigInt->new(12345); $x->{_a} = 5; -$x->bround(5); # must be no-op -ok ($x,'12345'); -ok ($x->{_a},5); - -# bround(n) should set _a -$x = Math::BigInt->new(12345); $x->{_a} = 5; -$x->bround(6); # must be no-op -ok ($x,'12345'); - -$x = Math::BigFloat->new('0.0061'); $x->bfround(-2); -ok ($x,'0.01'); - -############################################################################### -# rounding with already set precision/accuracy - -$x = Math::BigFloat->new(1); $x->{_p} = -5; -ok ($x,'1.00000'); - -# further rounding donw -ok ($x->bfround(-2),'1.00'); -ok ($x->{_p},-2); - -$x = Math::BigFloat->new(12345); $x->{_a} = 5; -ok ($x->bround(2),'12000'); -ok ($x->{_a},2); - -$x = Math::BigFloat->new('1.2345'); $x->{_a} = 5; -ok ($x->bround(2),'1.2'); -ok ($x->{_a},2); - -# mantissa/exponent format and A/P -$x = Math::BigFloat->new('12345.678'); $x->accuracy(4); -ok ($x,'12350'); ok ($x->{_a},4); ok_undef ($x->{_p}); -ok ($x->{_m}->{_f},1); ok ($x->{_e}->{_f},1); -ok_undef ($x->{_m}->{_a}); ok_undef ($x->{_e}->{_a}); -ok_undef ($x->{_m}->{_p}); ok_undef ($x->{_e}->{_p}); - -# check for no A/P in case of fallback -# result -$x = Math::BigFloat->new(100) / 3; -ok_undef ($x->{_a}); ok_undef ($x->{_p}); - -# result & reminder -$x = Math::BigFloat->new(100) / 3; ($x,$y) = $x->bdiv(3); -ok_undef ($x->{_a}); ok_undef ($x->{_p}); -ok_undef ($y->{_a}); ok_undef ($y->{_p}); - -############################################################################### -# math with two numbers with differen A and P - -$x = Math::BigFloat->new(12345); $x->accuracy(4); # '12340' -$y = Math::BigFloat->new(12345); $y->accuracy(2); # '12000' -ok ($x+$y,24000); # 12340+12000=> 24340 => 24000 - -$x = Math::BigFloat->new(54321); $x->accuracy(4); # '12340' -$y = Math::BigFloat->new(12345); $y->accuracy(3); # '12000' -ok ($x-$y,42000); # 54320+12300=> 42020 => 42000 - -$x = Math::BigFloat->new('1.2345'); $x->precision(-2); # '1.23' -$y = Math::BigFloat->new('1.2345'); $y->precision(-4); # '1.2345' -ok ($x+$y,'2.46'); # 1.2345+1.2300=> 2.4645 => 2.46 - -############################################################################### -# round should find and use proper class - -$x = Foo->new(); -ok ($x->round($Foo::accuracy),'a' x $Foo::accuracy); -ok ($x->round(undef,$Foo::precision),'p' x $Foo::precision); -ok ($x->bfround($Foo::precision),'p' x $Foo::precision); -ok ($x->bround($Foo::accuracy),'a' x $Foo::accuracy); - -############################################################################### -# find out whether _find_round_parameters is doing what's it's supposed to do - -$Math::BigInt::accuracy = undef; -$Math::BigInt::precision = undef; -$Math::BigInt::div_scale = 40; -$Math::BigInt::round_mode = 'odd'; - -$x = Math::BigInt->new(123); -my @params = $x->_find_round_parameters(); -ok (scalar @params,1); # nothing to round - -@params = $x->_find_round_parameters(1); -ok (scalar @params,4); # a=1 -ok ($params[0],$x); # self -ok ($params[1],1); # a -ok_undef ($params[2]); # p -ok ($params[3],'odd'); # round_mode - -@params = $x->_find_round_parameters(undef,2); -ok (scalar @params,4); # p=2 -ok ($params[0],$x); # self -ok_undef ($params[1]); # a -ok ($params[2],2); # p -ok ($params[3],'odd'); # round_mode - -eval { @params = $x->_find_round_parameters(undef,2,'foo'); }; -ok ($@ =~ /^Unknown round mode 'foo'/,1); - -@params = $x->_find_round_parameters(undef,2,'+inf'); -ok (scalar @params,4); # p=2 -ok ($params[0],$x); # self -ok_undef ($params[1]); # a -ok ($params[2],2); # p -ok ($params[3],'+inf'); # round_mode - -@params = $x->_find_round_parameters(2,-2,'+inf'); -ok (scalar @params,4); # p=2 -ok ($params[0],$x); # self -ok ($params[1],2); # a -ok ($params[2],-2); # p -ok ($params[3],'+inf'); # round_mode - -# all done - -############################################################################### -# Perl 5.005 does not like ok ($x,undef) - -sub ok_undef - { - my $x = shift; - - ok (1,1) and return if !defined $x; - ok ($x,'undef'); - } +$mbi->round_mode('odd'); ok ($Math::BigInt::rnd_mode,'odd'); +$mbf->round_mode('odd'); ok ($Math::BigInt::rnd_mode,'odd'); diff --git a/lib/Math/BigInt/t/require.t b/lib/Math/BigInt/t/require.t new file mode 100644 index 0000000..f98dbeb --- /dev/null +++ b/lib/Math/BigInt/t/require.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w + +use strict; +use Test; + +BEGIN + { + $| = 1; + chdir 't' if -d 't'; + unshift @INC, '../lib'; # for running manually + plan tests => 1; + } + +my ($try,$ans,$x); + +require Math::BigInt; $x = Math::BigInt->new(1); ++$x; + +#$try = 'require Math::BigInt; $x = Math::BigInt->new(1); ++$x;'; +#$ans = eval $try || 'undef'; +#print "# For '$try'\n" if (!ok "$ans" , '2' ); + +ok ($x||'undef',2); + +# all tests done + +1; + diff --git a/lib/Math/BigInt/t/sub_mbf.t b/lib/Math/BigInt/t/sub_mbf.t index 937a9c6..92d04e8 100755 --- a/lib/Math/BigInt/t/sub_mbf.t +++ b/lib/Math/BigInt/t/sub_mbf.t @@ -26,7 +26,8 @@ BEGIN } print "# INC = @INC\n"; - plan tests => 1367 + 4; # + 4 own tests + plan tests => 1528 + + 4; # + 4 own tests } use Math::BigFloat::Subclass; diff --git a/lib/Math/BigInt/t/sub_mbi.t b/lib/Math/BigInt/t/sub_mbi.t index 779416c..eeedafe 100755 --- a/lib/Math/BigInt/t/sub_mbi.t +++ b/lib/Math/BigInt/t/sub_mbi.t @@ -26,7 +26,7 @@ BEGIN } print "# INC = @INC\n"; - plan tests => 1865 + plan tests => 2005 + 4; # +4 own tests } diff --git a/lib/Math/BigInt/t/sub_mif.t b/lib/Math/BigInt/t/sub_mif.t new file mode 100644 index 0000000..01b87db --- /dev/null +++ b/lib/Math/BigInt/t/sub_mif.t @@ -0,0 +1,43 @@ +#!/usr/bin/perl -w + +# test rounding, accuracy, precicion and fallback, round_mode and mixing +# of classes + +use strict; +use Test; + +BEGIN + { + $| = 1; + # to locate the testing files + my $location = $0; $location =~ s/sub_mif.t//i; + if ($ENV{PERL_CORE}) + { + @INC = qw(../t/lib); # testing with the core distribution + } + unshift @INC, '../lib'; # for testing manually + if (-d 't') + { + chdir 't'; + require File::Spec; + unshift @INC, File::Spec->catdir(File::Spec->updir, $location); + } + else + { + unshift @INC, $location; + } + print "# INC = @INC\n"; + + plan tests => 428; + } + +use Math::BigInt::Subclass; +use Math::BigFloat::Subclass; + +use vars qw/$mbi $mbf/; + +$mbi = 'Math::BigInt::Subclass'; +$mbf = 'Math::BigFloat::Subclass'; + +require 'mbimbf.inc'; + diff --git a/lib/Math/BigInt/t/use.t b/lib/Math/BigInt/t/use.t new file mode 100644 index 0000000..c525098 --- /dev/null +++ b/lib/Math/BigInt/t/use.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w + +# use Module(); doesn't call impor() - thanx for cpan test David. M. Town and +# Andreas Marcel Riechert for spotting it. It is fixed by the same code that +# fixes require Math::BigInt, but we make a test to be sure it really works. + +use strict; +use Test; + +BEGIN + { + $| = 1; + chdir 't' if -d 't'; + unshift @INC, '../lib'; # for running manually + plan tests => 1; + } + +my ($try,$ans,$x); + +use Math::BigInt(); $x = Math::BigInt->new(1); ++$x; + +ok ($x||'undef',2); + +# all tests done + +1; + diff --git a/t/lib/Math/BigFloat/Subclass.pm b/t/lib/Math/BigFloat/Subclass.pm index 209aa1d..ca9bbce 100644 --- a/t/lib/Math/BigFloat/Subclass.pm +++ b/t/lib/Math/BigFloat/Subclass.pm @@ -6,13 +6,13 @@ require 5.005_02; use strict; use Exporter; -use Math::BigFloat(1.23); +use Math::BigFloat(1.27); use vars qw($VERSION @ISA $PACKAGE $accuracy $precision $round_mode $div_scale); @ISA = qw(Exporter Math::BigFloat); -$VERSION = 0.01; +$VERSION = 0.02; # Globals $accuracy = $precision = undef; @@ -25,12 +25,11 @@ sub new my $class = ref($proto) || $proto; my $value = shift; - # Set to 0 if not provided, but don't use || (this would trigger for - # a passed objects to see if they are zero) - $value = 0 if !defined $value; - + my $a = $accuracy; $a = $_[0] if defined $_[0]; + my $p = $precision; $p = $_[1] if defined $_[1]; # Store the floating point value - my $self = bless Math::BigFloat->new($value), $class; + my $self = Math::BigFloat->new($value,$a,$p,$round_mode); + bless $self, $class; $self->{'_custom'} = 1; # make sure this never goes away return $self; } diff --git a/t/lib/Math/BigInt/BareCalc.pm b/t/lib/Math/BigInt/BareCalc.pm index 9cc7e94..7c56c4e 100644 --- a/t/lib/Math/BigInt/BareCalc.pm +++ b/t/lib/Math/BigInt/BareCalc.pm @@ -14,13 +14,14 @@ $VERSION = '0.02'; # uses Calc, but only features the strictly necc. methods. -use Math::BigInt::Calc v0.17; +use Math::BigInt::Calc '0.18'; BEGIN { foreach (qw/ base_len new zero one two copy str num add sub mul div inc dec acmp len digit zeros is_zero is_one is_odd is_even is_one check + to_small to_large /) { my $name = "Math::BigInt::Calc::_$_"; diff --git a/t/lib/Math/BigInt/Subclass.pm b/t/lib/Math/BigInt/Subclass.pm index 3656b9f..03795da 100644 --- a/t/lib/Math/BigInt/Subclass.pm +++ b/t/lib/Math/BigInt/Subclass.pm @@ -6,14 +6,14 @@ require 5.005_02; use strict; use Exporter; -use Math::BigInt(1.45); +use Math::BigInt(1.49); use vars qw($VERSION @ISA $PACKAGE @EXPORT_OK $accuracy $precision $round_mode $div_scale); @ISA = qw(Exporter Math::BigInt); @EXPORT_OK = qw(bgcd); -$VERSION = 0.01; +$VERSION = 0.02; # Globals $accuracy = $precision = undef; @@ -26,10 +26,10 @@ sub new my $class = ref($proto) || $proto; my $value = shift; - $value = 0 if !defined $value; # no || 0 here! - - # Store the floating point value - my $self = bless Math::BigInt->new($value), $class; + my $a = $accuracy; $a = $_[0] if defined $_[0]; + my $p = $precision; $p = $_[1] if defined $_[1]; + my $self = Math::BigInt->new($value,$a,$p,$round_mode); + bless $self,$class; $self->{'_custom'} = 1; # make sure this never goes away return $self; } @@ -47,7 +47,6 @@ sub blcm sub import { my $self = shift; -# Math::BigInt->import(@_); $self->SUPER::import(@_); # need it for subclasses #$self->export_to_level(1,$self,@_); # need this ? }