From 394e6ffb59de984c27a7dce4842d9c594c141888 Mon Sep 17 00:00:00 2001 From: Jarkko Hietaniemi Date: Fri, 7 Dec 2001 01:30:25 +0000 Subject: [PATCH] Upgrade to Math::BigInt 1.48. p4raw-id: //depot/perl@13505 --- MANIFEST | 4 +- lib/Math/BigFloat.pm | 217 +++++++------- lib/Math/BigInt.pm | 265 +++++++++-------- lib/Math/BigInt/Calc.pm | 640 +++++++++++++++++++++++++++++----------- lib/Math/BigInt/t/bare_mbi.t | 42 +++ lib/Math/BigInt/t/bigfltpm.inc | 54 +++- lib/Math/BigInt/t/bigfltpm.t | 2 +- lib/Math/BigInt/t/bigintc.t | 20 +- lib/Math/BigInt/t/bigintpm.inc | 153 +++++++++- lib/Math/BigInt/t/bigintpm.t | 5 +- lib/Math/BigInt/t/sub_mbf.t | 2 +- lib/Math/BigInt/t/sub_mbi.t | 10 +- t/lib/Math/BigFloat/Subclass.pm | 7 +- t/lib/Math/BigInt/BareCalc.pm | 35 +++ t/lib/Math/BigInt/Subclass.pm | 5 +- 15 files changed, 1015 insertions(+), 446 deletions(-) create mode 100644 lib/Math/BigInt/t/bare_mbi.t create mode 100644 t/lib/Math/BigInt/BareCalc.pm diff --git a/MANIFEST b/MANIFEST index d73cbf0..64e87cf 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1057,6 +1057,7 @@ lib/look.pl A "look" equivalent lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package lib/Math/BigInt.pm An arbitrary precision integer arithmetic package lib/Math/BigInt/Calc.pm Pure Perl module to support Math::BigInt +lib/Math/BigInt/t/bare_mbi.t Test Math::BigInt::CareCalc lib/Math/BigInt/t/bigfltpm.inc Shared tests for bigfltpm.t and sub_mbf.t lib/Math/BigInt/t/bigfltpm.t See if BigFloat.pm works lib/Math/BigInt/t/bigintc.t See if BigInt/Calc.pm works @@ -1852,8 +1853,8 @@ pod/Makefile.SH generate Makefile whichs makes pods into something else pod/perl.pod Top level perl documentation pod/perl5004delta.pod Changes from 5.003 to 5.004 pod/perl5005delta.pod Changes from 5.004 to 5.005 -pod/perl56delta.pod Changes from 5.005 to 5.6 pod/perl561delta.pod Changes from 5.6.0 to 5.6.1 +pod/perl56delta.pod Changes from 5.005 to 5.6 pod/perl570delta.pod Changes from 5.6 to 5.7.0 pod/perl571delta.pod Changes from 5.7.0 to 5.7.1 pod/perl572delta.pod Changes from 5.7.1 to 5.7.2 @@ -2096,6 +2097,7 @@ t/lib/h2ph.pht Generated output from h2ph.h by h2ph, for comparison t/lib/locale/latin1 Part of locale.t in Latin 1 t/lib/locale/utf8 Part of locale.t in UTF8 t/lib/Math/BigFloat/Subclass.pm Empty subclass of BigFloat for test +t/lib/Math/BigInt/BareCalc.pm Bigint's simulation of Calc t/lib/Math/BigInt/Subclass.pm Empty subclass of BigInt for test t/lib/sample-tests/bailout Test data for Test::Harness t/lib/sample-tests/combined Test data for Test::Harness diff --git a/lib/Math/BigFloat.pm b/lib/Math/BigFloat.pm index a490e62..a258777 100644 --- a/lib/Math/BigFloat.pm +++ b/lib/Math/BigFloat.pm @@ -7,27 +7,24 @@ # _a: accuracy # _p: precision # _f: flags, used to signal MBI not to touch our private parts -# _cow: Copy-On-Write (NRY) package Math::BigFloat; -$VERSION = '1.25'; +$VERSION = '1.26'; require 5.005; use Exporter; use Math::BigInt qw/objectify/; @ISA = qw( Exporter Math::BigInt); -# can not export bneg/babs since the are only in MBI -@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 - ); - -#@EXPORT = qw( ); +#@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/; my $class = "Math::BigFloat"; @@ -74,13 +71,13 @@ 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 - fneg fint facmp fcmp fzero fnan finf finc fdec - fceil ffloor + fint facmp fcmp fzero fnan finf finc fdec + fceil ffloor frsft flsft fone /; # valid method's that need to 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 fabs babs + accuracy precision div_scale round_mode fneg fabs babs fnot /; sub method_alias { return exists $methods{$_[0]||''}; } @@ -162,6 +159,7 @@ sub bnan $self->{_m} = Math::BigInt->bzero(); $self->{_e} = Math::BigInt->bzero(); $self->{sign} = $nan; + ($self->{_a},$self->{_p}) = @_ if @_ > 0; return $self; } @@ -179,6 +177,7 @@ sub binf $self->{_m} = Math::BigInt->bzero(); $self->{_e} = Math::BigInt->bzero(); $self->{sign} = $sign.'inf'; + ($self->{_a},$self->{_p}) = @_ if @_ > 0; return $self; } @@ -196,6 +195,7 @@ sub bone $self->{_m} = Math::BigInt->bone(); $self->{_e} = Math::BigInt->bzero(); $self->{sign} = $sign; + ($self->{_a},$self->{_p}) = @_ if @_ > 0; return $self; } @@ -211,6 +211,7 @@ sub bzero $self->{_m} = Math::BigInt->bzero(); $self->{_e} = Math::BigInt->bone(); $self->{sign} = '+'; + ($self->{_a},$self->{_p}) = @_ if @_ > 0; return $self; } @@ -321,16 +322,6 @@ sub numify ############################################################################## # public stuff (usually prefixed with "b") -# really? Just for exporting them is not what I had in mind -#sub babs -# { -# $class->SUPER::babs($class,@_); -# } -#sub bneg -# { -# $class->SUPER::bneg($class,@_); -# } - # tels 2001-08-04 # todo: this must be overwritten and return NaN for non-integer values # band(), bior(), bxor(), too @@ -424,12 +415,12 @@ sub bacmp my $lx = $lxm + $x->{_e}; my $ly = $lym + $y->{_e}; # print "x $x y $y lx $lx ly $ly\n"; - my $l = $lx - $ly; # $l = -$l if $x->{sign} eq '-'; + my $l = $lx - $ly; # print "$l $x->{sign}\n"; return $l <=> 0 if $l != 0; # lengths (corrected by exponent) are equal - # so make mantissa euqal length by padding with zero (shift left) + # so make mantissa equal-length by padding with zero (shift left) my $diff = $lxm - $lym; my $xm = $x->{_m}; # not yet copy it my $ym = $y->{_m}; @@ -442,22 +433,7 @@ sub bacmp $xm = $x->{_m}->copy()->blsft(-$diff,10); } my $rc = $xm->bcmp($ym); - # $rc = -$rc if $x->{sign} eq '-'; # -124 < -123 return $rc <=> 0; - -# # signs are ignored, so check length -# # length(x) is length(m)+e aka length of non-fraction part -# # the longer one is bigger -# my $l = $x->length() - $y->length(); -# #print "$l\n"; -# return $l if $l != 0; -# #print "equal lengths\n"; -# -# # if both are equal long, make full compare -# # first compare only the mantissa -# # if mantissa are equal, compare fractions -# -# return $x->{_m} <=> $y->{_m} || $x->{_e} <=> $y->{_e}; } sub badd @@ -703,15 +679,11 @@ sub bmul } # aEb * cEd = (a*c)E(b+d) - $x->{_m} = $x->{_m} * $y->{_m}; - #print "m: $x->{_m}\n"; - $x->{_e} = $x->{_e} + $y->{_e}; - #print "e: $x->{_m}\n"; + $x->{_m}->bmul($y->{_m}); + $x->{_e}->badd($y->{_e}); # adjust sign: $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+'; - #print "s: $x->{sign}\n"; - $x->bnorm(); - return $x->round($a,$p,$r,$y); + return $x->bnorm()->round($a,$p,$r,$y); } sub bdiv @@ -735,18 +707,12 @@ sub bdiv ? ($x->binf($x->{sign}),$self->bnan()) : $x->binf($x->{sign}) if ($x->{sign} =~ /^[+-]$/ && $y->is_zero()); - # promote BigInts and it's subclasses (except when already a BigFloat) - $y = $self->new($y) unless $y->isa('Math::BigFloat'); - - # old, broken way - # $y = $class->new($y) if ref($y) ne $self; # promote bigints + # x== 0 or y == 1 or y == -1 + return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero(); - # print "mbf bdiv $x ",ref($x)," ",$y," ",ref($y),"\n"; # we need to limit the accuracy to protect against overflow - my $fallback = 0; my $scale = 0; -# print "s=$scale a=",$a||'undef'," p=",$p||'undef'," r=",$r||'undef',"\n"; my @params = $x->_find_round_parameters($a,$p,$r,$y); # no rounding at all, so must use fallback @@ -764,40 +730,29 @@ sub bdiv # enough... $scale = abs($params[1] || $params[2]) + 4; # take whatever is defined } - # print "s=$scale a=",$params[1]||'undef'," p=",$params[2]||'undef'," f=$fallback\n"; my $lx = $x->{_m}->length(); my $ly = $y->{_m}->length(); $scale = $lx if $lx > $scale; $scale = $ly if $ly > $scale; -# print "scale $scale $lx $ly\n"; my $diff = $ly - $lx; $scale += $diff if $diff > 0; # if lx << ly, but not if ly << lx! - return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero(); - $x->{sign} = $x->{sign} ne $y->sign() ? '-' : '+'; # check for / +-1 ( +/- 1E0) - if ($y->is_one()) + if (!$y->is_one()) { - return wantarray ? ($x,$self->bzero()) : $x; + # promote BigInts and it's subclasses (except when already a BigFloat) + $y = $self->new($y) unless $y->isa('Math::BigFloat'); + + # calculate the result to $scale digits and then round it + # a * 10 ** b / c * 10 ** d => a/c * 10 ** (b-d) + $x->{_m}->blsft($scale,10); + $x->{_m}->bdiv( $y->{_m} ); # a/c + $x->{_e}->bsub( $y->{_e} ); # b-d + $x->{_e}->bsub($scale); # correct for 10**scale + $x->bnorm(); # remove trailing 0's } - # calculate the result to $scale digits and then round it - # a * 10 ** b / c * 10 ** d => a/c * 10 ** (b-d) - #$scale = 82; - #print "self: $self x: $x ref(x) ", ref($x)," m: $x->{_m}\n"; - $x->{_m}->blsft($scale,10); - #print "m: $x->{_m} $y->{_m}\n"; - $x->{_m}->bdiv( $y->{_m} ); # a/c - #print "m: $x->{_m}\n"; - #print "e: $x->{_e} $y->{_e} ",$scale,"\n"; - $x->{_e}->bsub($y->{_e}); # b-d - #print "e: $x->{_e}\n"; - $x->{_e}->bsub($scale); # correct for 10**scale - #print "after div: m: $x->{_m} e: $x->{_e}\n"; - $x->bnorm(); # remove trailing 0's - #print "after norm: m: $x->{_m} e: $x->{_e}\n"; - # shortcut to not run trough _find_round_parameters again if (defined $params[1]) { @@ -815,8 +770,16 @@ sub bdiv if (wantarray) { - my $rem = $x->copy(); - $rem->bmod($y,$params[1],$params[2],$params[3]); + my $rem; + if (!$y->is_one()) + { + $rem = $x->copy(); + $rem->bmod($y,$params[1],$params[2],$params[3]); + } + else + { + $rem = $self->bzero(); + } if ($fallback) { # clear a/p after round, since user did not request it @@ -847,7 +810,7 @@ sub bsqrt return $x->bnan() if $x->{sign} eq 'NaN' || $x->{sign} =~ /^-/; # <0, NaN return $x if $x->{sign} eq '+inf'; # +inf - return $x if $x->is_zero() || $x == 1; + 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); @@ -859,43 +822,53 @@ sub bsqrt $a = $self->div_scale(); # and round to it $fallback = 1; # to clear a/p afterwards } + 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 + # digits after the dot + && ($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) + } + $gs = $self->new( $gs ); + my $lx = $x->{_m}->length(); $scale = $lx if $scale < $lx; - my $e = Math::BigFloat->new("1E-$scale"); # make test variable + my $e = $self->new("1E-$scale"); # make test variable return $x->bnan() if $e->sign() eq 'NaN'; # start with some reasonable guess - #$x *= 10 ** ($len - $org->{_e}); $x /= 2; # !?!? - $lx = $lx+$x->{_e}; - $lx = 1 if $lx < 1; - my $gs = Math::BigFloat->new('1'. ('0' x $lx)); - -# print "first guess: $gs (x $x) scale $scale\n"; - +# $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 = Math::BigFloat->new(2); + my $two = $self->new(2); # promote BigInts and it's subclasses (except when already a BigFloat) $y = $self->new($y) unless $y->isa('Math::BigFloat'); - # old, broken way - # $x = Math::BigFloat->new($x) if ref($x) ne $class; # promote BigInts my $rem; - # $scale = 2; +# my $steps = 0; while ($diff >= $e) { - return $x->bnan() if $gs->is_zero(); - $rem = $y->copy(); $rem->bdiv($gs,$scale); - #print "y $y gs $gs ($gs->{_a}) rem (y/gs)\n $rem\n"; - $x = ($rem + $gs); - #print "x $x rem $rem gs $gs gsa: $gs->{_a}\n"; - $x->bdiv($two,$scale); - #print "x $x (/2)\n"; + # 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(); +# $steps++; } -# print "before $x $x->{_a} ",$a||'a undef'," ",$p||'p undef',"\n"; +# print "steps $steps\n"; $x->round($a,$p,$r); -# print "after $x $x->{_a} ",$a||'a undef'," ",$p||'p undef',"\n"; if ($fallback) { # clear a/p after round, since user did not request it @@ -917,7 +890,8 @@ sub bpow return $x->bone() if $y->is_zero(); return $x if $x->is_one() || $y->is_one(); my $y1 = $y->as_number(); # make bigint (trunc) - if ($x == -1) + # if ($x == -1) + if ($x->{sign} eq '-' && $x->{_m}->is_one() && $x->{_e}->is_zero()) { # if $x == -1 and odd/even y => +1/-1 because +-1 ^ (+-1) => +-1 return $y1->is_odd() ? $x : $x->babs(1); @@ -1123,6 +1097,30 @@ sub bceil return $x->round($a,$p,$r); } +sub brsft + { + # shift right by $y (divide by power of 2) + my ($self,$x,$y,$n,$a,$p,$r) = objectify(2,@_); + + return $x if $x->modify('brsft'); + return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf + + $n = 2 if !defined $n; $n = Math::BigFloat->new($n); + $x->bdiv($n ** $y,$a,$p,$r,$y); + } + +sub blsft + { + # shift right by $y (divide by power of 2) + my ($self,$x,$y,$n,$a,$p,$r) = objectify(2,@_); + + return $x if $x->modify('brsft'); + return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf + + $n = 2 if !defined $n; $n = Math::BigFloat->new($n); + $x->bmul($n ** $y,$a,$p,$r,$y); + } + ############################################################################### sub DESTROY @@ -1147,7 +1145,6 @@ sub AUTOLOAD require Carp; Carp::croak ("Can't call a method without name"); } - # try one level up, but subst. bxxx() for fxxx() since MBI only got bxxx() if (!method_hand_up($name)) { # delayed load of Carp and avoid recursion @@ -1250,7 +1247,7 @@ 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 + return $x; # MBI bnorm is no-op, so dont call it } ############################################################################## @@ -1258,8 +1255,8 @@ sub bnorm sub as_number { - # return a bigint representation of this BigFloat number - my $x = shift; my $class = ref($x) || $x; $x = $class->new(shift) unless ref($x); + # return copy as a bigint representation of this BigFloat number + my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_); my $z; if ($x->{_e}->is_zero()) diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm index a1b7b8f..354bc71 100644 --- a/lib/Math/BigInt.pm +++ b/lib/Math/BigInt.pm @@ -1,9 +1,5 @@ #!/usr/bin/perl -w -# Qs: what exactly happens on numify of HUGE numbers? overflow? -# $a = -$a is much slower (making copy of $a) than $a->bneg(), hm!? -# (copy_on_write will help there, but that is not yet implemented) - # The following hash values are used: # value: unsigned int with actual value (as a Math::BigInt::Calc or similiar) # sign : +,-,NaN,+inf,-inf @@ -18,18 +14,21 @@ package Math::BigInt; my $class = "Math::BigInt"; require 5.005; -$VERSION = '1.47'; +$VERSION = '1.48'; use Exporter; @ISA = qw( Exporter ); -@EXPORT_OK = qw( 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 objectify _swap +# 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 = qw( ); use vars qw/$round_mode $accuracy $precision $div_scale $rnd_mode/; use strict; @@ -291,21 +290,26 @@ sub copy return unless ref($x); # only for objects my $self = {}; bless $self,$c; + my $r; foreach my $k (keys %$x) { if ($k eq 'value') { - $self->{value} = $CALC->_copy($x->{value}); + $self->{value} = $CALC->_copy($x->{value}); next; + } + if (!($r = ref($x->{$k}))) + { + $self->{$k} = $x->{$k}; next; } - elsif (ref($x->{$k}) eq 'SCALAR') + if ($r eq 'SCALAR') { $self->{$k} = \${$x->{$k}}; } - elsif (ref($x->{$k}) eq 'ARRAY') + elsif ($r eq 'ARRAY') { $self->{$k} = [ @{$x->{$k}} ]; } - elsif (ref($x->{$k}) eq 'HASH') + elsif ($r eq 'HASH') { # only one level deep! foreach my $h (keys %{$x->{$k}}) @@ -313,14 +317,17 @@ sub copy $self->{$k}->{$h} = $x->{$k}->{$h}; } } - elsif (ref($x->{$k})) + else # normal ref { - my $c = ref($x->{$k}); - $self->{$k} = $c->new($x->{$k}); # no copy() due to deep rec - } - else - { - $self->{$k} = $x->{$k}; + my $xk = $x->{$k}; + if ($xk->can('copy')) + { + $self->{$k} = $xk->copy(); + } + else + { + $self->{$k} = $xk->new($xk); + } } } $self; @@ -425,6 +432,7 @@ sub bnan return if $self->modify('bnan'); $self->{value} = $CALC->_zero(); $self->{sign} = $nan; + delete $self->{_a}; delete $self->{_p}; # rounding NaN is silly return $self; } @@ -442,6 +450,7 @@ sub binf return if $self->modify('binf'); $self->{value} = $CALC->_zero(); $self->{sign} = $sign.'inf'; + ($self->{_a},$self->{_p}) = @_; # take over requested rounding return $self; } @@ -458,6 +467,7 @@ sub bzero return if $self->modify('bzero'); $self->{value} = $CALC->_zero(); $self->{sign} = '+'; + ($self->{_a},$self->{_p}) = @_; # take over requested rounding return $self; } @@ -468,7 +478,7 @@ sub bone my $self = shift; my $sign = shift; $sign = '+' if !defined $sign || $sign ne '-'; $self = $class if !defined $self; - + if (!ref($self)) { my $c = $self; $self = {}; bless $self, $c; @@ -476,6 +486,7 @@ sub bone return if $self->modify('bone'); $self->{value} = $CALC->_one(); $self->{sign} = $sign; + ($self->{_a},$self->{_p}) = @_; # take over requested rounding return $self; } @@ -519,7 +530,7 @@ sub bstr sub numify { - # Make a number from a BigInt object + # Make a "normal" scalar from a BigInt object my $x = shift; $x = $class->new($x) unless ref $x; return $x->{sign} if $x->{sign} !~ /^[+-]$/; my $num = $CALC->_num($x->{value}); @@ -548,19 +559,19 @@ sub _find_round_parameters # A and P settings. # This does not yet handle $x with A, and $y with P (which should be an # error). - my $self = shift; - my $a = shift; # accuracy, if given by caller - my $p = shift; # precision, if given by caller - my $r = shift; # round_mode, if given by caller - my @args = @_; # all 'other' arguments (0 for unary, 1 for binary ops) + 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 - my $c = ref($self); # find out class of argument(s) - unshift @args,$self; # add 'first' argument + # $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" @@ -651,7 +662,7 @@ sub bneg return $x if $x->modify('bneg'); # for +0 dont negate (to have always normalized) return $x if $x->is_zero(); - $x->{sign} =~ tr/+\-/-+/; # does nothing for NaN + $x->{sign} =~ tr/+-/-+/; # does nothing for NaN $x; } @@ -955,7 +966,7 @@ sub is_one $sign = '' if !defined $sign; $sign = '+' if $sign ne '-'; return 0 if $x->{sign} ne $sign; # -1 != +1, NaN, +-inf aren't either - return $CALC->_is_one($x->{value}); + $CALC->_is_one($x->{value}); } sub is_odd @@ -965,7 +976,7 @@ sub is_odd my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't - return $CALC->_is_odd($x->{value}); + $CALC->_is_odd($x->{value}); } sub is_even @@ -975,7 +986,7 @@ sub is_even my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't - return $CALC->_is_even($x->{value}); + $CALC->_is_even($x->{value}); } sub is_positive @@ -985,7 +996,7 @@ sub is_positive my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); return 1 if $x->{sign} =~ /^\+/; - return 0; + 0; } sub is_negative @@ -995,7 +1006,7 @@ sub is_negative my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); return 1 if ($x->{sign} =~ /^-/); - return 0; + 0; } ############################################################################### @@ -1114,20 +1125,18 @@ sub bdiv my $xsign = $x->{sign}; # keep $x->{sign} = ($x->{sign} ne $y->{sign} ? '-' : '+'); # check for / +-1 (cant use $y->is_one due to '-' - if (($y == 1) || ($y == -1)) # slow! + if ($CALC->_is_one($y->{value})) { return wantarray ? ($x,$self->bzero()) : $x; } - # call div here - my $rem = $self->bzero(); - ($x->{value},$rem->{value}) = $CALC->_div($x->{value},$y->{value}); - # do not leave result "-0"; - $x->{sign} = '+' if $CALC->_is_zero($x->{value}); - $x->round($a,$p,$r,$y); - + my $rem; if (wantarray) { + 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); if (! $CALC->_is_zero($rem->{value})) { $rem->{sign} = $y->{sign}; @@ -1140,7 +1149,10 @@ sub bdiv $rem->round($a,$p,$r,$x,$y); return ($x,$rem); } - return $x; + + $x->{value} = $CALC->_div($x->{value},$y->{value}); + $x->{sign} = '+' if $CALC->_is_zero($x->{value}); + $x->round($a,$p,$r,$y); } sub bmod @@ -1175,7 +1187,7 @@ sub bmod { $x = (&bdiv($self,$x,$y))[1]; # slow way } - $x->bround($a,$p,$r); + $x->round($a,$p,$r); } sub bpow @@ -1191,7 +1203,6 @@ sub bpow 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(); - #if ($x->{sign} eq '-' && @{$x->{value}} == 1 && $x->{value}->[0] == 1) if ($x->{sign} eq '-' && $CALC->_is_one($x->{value})) { # if $x == -1 and odd/even y => +1/-1 @@ -1288,7 +1299,7 @@ sub band return $x if $x->modify('band'); return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/); - return $x->bzero() if $y->is_zero(); + return $x->bzero() if $y->is_zero() || $x->is_zero(); my $sign = 0; # sign of result $sign = 1 if ($x->{sign} eq '-') && ($y->{sign} eq '-'); @@ -1301,7 +1312,7 @@ sub band return $x->round($a,$p,$r); } - my $m = new Math::BigInt 1; my ($xr,$yr); + my $m = Math::BigInt->bone(); my ($xr,$yr); my $x10000 = new Math::BigInt (0x1000); my $y1 = copy(ref($x),$y); # make copy $y1->babs(); # and positive @@ -1344,8 +1355,8 @@ sub bior return $x->round($a,$p,$r); } - my $m = new Math::BigInt 1; my ($xr,$yr); - my $x10000 = new Math::BigInt (0x10000); + my $m = Math::BigInt->bone(); my ($xr,$yr); + my $x10000 = Math::BigInt->new(0x10000); my $y1 = copy(ref($x),$y); # make copy $y1->babs(); # and positive my $x1 = $x->copy()->babs(); $x->bzero(); # modify x in place! @@ -1374,7 +1385,6 @@ sub bxor return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/); return $x if $y->is_zero(); - return $x->bzero() if $x == $y; # shortcut my $sign = 0; # sign of result $sign = 1 if $x->{sign} ne $y->{sign}; @@ -1388,8 +1398,8 @@ sub bxor return $x->round($a,$p,$r); } - my $m = new Math::BigInt 1; my ($xr,$yr); - my $x10000 = new Math::BigInt (0x10000); + my $m = $self->bone(); my ($xr,$yr); + my $x10000 = Math::BigInt->new(0x10000); my $y1 = copy(ref($x),$y); # make copy $y1->babs(); # and positive my $x1 = $x->copy()->babs(); $x->bzero(); # modify x in place! @@ -1444,29 +1454,36 @@ sub _trailing_zeros sub bsqrt { - my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_); + my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_); - return $x->bnan() if $x->{sign} =~ /\-|$nan/; # -x or NaN => NaN - return $x->bzero() if $x->is_zero(); # 0 => 0 - return $x if $x == 1; # 1 => 1 + return $x->bnan() if $x->{sign} ne '+'; # -x or inf or NaN => NaN + return $x->bzero($a,$p) if $x->is_zero(); # 0 => 0 + return $x->round($a,$p,$r) if $x->is_one(); # 1 => 1 + return $x->bone($a,$p) if $x < 4; # 2,3 => 1 - my $y = $x->copy(); # give us one more digit accur. + if ($CALC->can('_sqrt')) + { + $x->{value} = $CALC->_sqrt($x->{value}); + return $x->round($a,$p,$r); + } + + my $y = $x->copy(); my $l = int($x->length()/2); - $x->bzero(); - $x->binc(); # keep ref($x), but modify it - $x *= 10 ** $l; - - # print "x: $y guess $x\n"; + $x->bone(); # keep ref($x), but modify it + $x->blsft($l,10); my $last = $self->bzero(); - while ($last != $x) + my $two = $self->new(2); + my $lastlast = $x+$two; + while ($last != $x && $lastlast != $x) { - $last = $x; + $lastlast = $last; $last = $x; $x += $y / $x; - $x /= 2; + $x /= $two; } - return $x; + $x-- if $x * $x > $y; # overshot? + return $x->round($a,$p,$r); } sub exponent @@ -1725,13 +1742,13 @@ sub _swap # args, hence the copy(). # You can override this method in a subclass, the overload section will call # $object->_swap() to make sure it arrives at the proper subclass, with some - # exceptions like '+' and '-'. + # exceptions like '+' and '-'. To make '+' and '-' work, you also need to + # specify your own overload for them. # object, (object|scalar) => preserve first and make copy # scalar, object => swapped, re-swap and create new from first # (using class of second object, not $class!!) my $self = shift; # for override in subclass - #print "swap $self 0:$_[0] 1:$_[1] 2:$_[2]\n"; if ($_[2]) { my $c = ref ($_[0]) || $class; # fallback $class should not happen @@ -1900,6 +1917,11 @@ sub __from_hex my $hs = shift; my $x = Math::BigInt->bzero(); + + # strip underscores + $$hs =~ s/([0-9a-fA-F])_([0-9a-fA-F])/$1$2/g; + $$hs =~ s/([0-9a-fA-F])_([0-9a-fA-F])/$1$2/g; + return $x->bnan() if $$hs !~ /^[\-\+]?0x[0-9A-Fa-f]+$/; my $sign = '+'; $sign = '-' if ($$hs =~ /^-/); @@ -1938,6 +1960,9 @@ sub __from_bin my $bs = shift; my $x = Math::BigInt->bzero(); + # strip underscores + $$bs =~ s/([01])_([01])/$1$2/g; + $$bs =~ s/([01])_([01])/$1$2/g; return $x->bnan() if $$bs !~ /^[+-]?0b[01]+$/; my $mul = Math::BigInt->bzero(); $mul++; @@ -1959,9 +1984,9 @@ 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',$val)); - # print "$val ",substr($$bs,$i,16),"\n"; + # slower: + # $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 --; $x += $mul * $val if $val != 0; $mul *= $x256 if $len >= 0; # skip last mul @@ -1994,11 +2019,12 @@ sub _split # invalid starting char? return if $$x !~ /^[+-]?(\.?[0-9]|0b[0-1]|0x[0-9a-fA-F])/; - $$x =~ s/(\d)_(\d)/$1$2/g; # strip underscores between digits - $$x =~ s/(\d)_(\d)/$1$2/g; # do twice for 1_2_3 - return __from_hex($x) if $$x =~ /^[\-\+]?0x/; # hex string return __from_bin($x) if $$x =~ /^[\-\+]?0b/; # binary string + + # strip underscores between digits + $$x =~ s/(\d)_(\d)/$1$2/g; + $$x =~ s/(\d)_(\d)/$1$2/g; # do twice for 1_2_3 # some possible inputs: # 2.1234 # 0.12 # 1 # 1E1 # 2.134E1 # 434E-10 # 1.02009E-2 @@ -2685,13 +2711,12 @@ numerical sense, e.g. $m might get minimized. =head1 EXAMPLES - use Math::BigInt qw(bstr); + use Math::BigInt; sub bint { Math::BigInt->new(shift); } - $x = bstr("1234") # string "1234" + $x = Math::BigInt->bstr("1234") # string "1234" $x = "$x"; # same as bstr() - $x = bneg("1234") # Bigint "-1234" $x = Math::BigInt->bneg("1234"); # Bigint "-1234" $x = Math::BigInt->babs("-12345"); # Bigint "12345" $x = Math::BigInt->bnorm("-0 00"); # BigInt "0" @@ -2701,10 +2726,9 @@ numerical sense, e.g. $m might get minimized. $x = $x + 5 / 2; # BigInt "3" $x = $x ** 3; # BigInt "27" $x *= 2; # BigInt "54" - $x = new Math::BigInt; # BigInt "0" + $x = Math::BigInt->new(0); # BigInt "0" $x--; # BigInt "-1" $x = Math::BigInt->badd(4,5) # BigInt "9" - $x = Math::BigInt::badd(4,5) # BigInt "9" print $x->bsstr(); # 9e+0 Examples for rounding: @@ -2714,22 +2738,22 @@ Examples for rounding: $x = Math::BigFloat->new(123.4567); $y = Math::BigFloat->new(123.456789); - $Math::BigFloat::accuracy = 4; # no more A than 4 + Math::BigFloat->accuracy(4); # no more A than 4 ok ($x->copy()->fround(),123.4); # even rounding print $x->copy()->fround(),"\n"; # 123.4 Math::BigFloat->round_mode('odd'); # round to odd print $x->copy()->fround(),"\n"; # 123.5 - $Math::BigFloat::accuracy = 5; # no more A than 5 + Math::BigFloat->accuracy(5); # no more A than 5 Math::BigFloat->round_mode('odd'); # round to odd print $x->copy()->fround(),"\n"; # 123.46 $y = $x->copy()->fround(4),"\n"; # A = 4: 123.4 print "$y, ",$y->accuracy(),"\n"; # 123.4, 4 - $Math::BigFloat::accuracy = undef; # A not important - $Math::BigFloat::precision = 2; # P important - print $x->copy()->bnorm(),"\n"; # 123.46 - print $x->copy()->fround(),"\n"; # 123.46 + Math::BigFloat->accuracy(undef); # A not important now + Math::BigFloat->precision(2); # P important + print $x->copy()->bnorm(),"\n"; # 123.46 + print $x->copy()->fround(),"\n"; # 123.46 Examples for converting: @@ -2760,7 +2784,15 @@ so that + '123456789123456789'; do not work. You need an explicit Math::BigInt->new() around one of the -operands. +operands. You should also quote large constants to protect loss of precision: + + use Math::Bigint; + + $x = Math::BigInt->new('1234567889123456789123456789123456789'); + +Without the quotes Perl would convert the large number to a floating point +constant at compile time and then hand the result to BigInt, which results in +an truncated result or a NaN. =head1 PERFORMANCE @@ -2772,12 +2804,20 @@ $x += $y is MUCH faster than $x = $x + $y since making the copy of $x takes more time then the actual addition. With a technique called copy-on-write, the cost of copying with overload could -be minimized or even completely avoided. This is currently not implemented. +be minimized or even completely avoided. A test implementation of COW did show +performance gains for overloaded math, but introduced a performance loss due +to a constant overhead for all other operatons. + +The rewritten version of this module is slower on certain operations, like +new(), bstr() and numify(). The reason are that it does now more work and +handles more cases. The time spent in these operations is usually gained in +the other operations so that programs on the average should get faster. If +they don't, please contect the author. -The new version of this module is slower on new(), bstr() and numify(). Some -operations may be slower for small numbers, but are significantly faster for -big numbers. Other operations are now constant (O(1), like bneg(), babs() -etc), instead of O(N) and thus nearly always take much less time. +Some operations may be slower for small numbers, but are significantly faster +for big numbers. Other operations are now constant (O(1), like bneg(), babs() +etc), instead of O(N) and thus nearly always take much less time. These +optimizations were done on purpose. If you find the Calc module to slow, try to install any of the replacement modules and see if they help you. @@ -2788,20 +2828,9 @@ You can use an alternative library to drive Math::BigInt via: use Math::BigInt lib => 'Module'; -The default is called Math::BigInt::Calc and is a pure-perl implementation -that consists mainly of the standard routine present in earlier versions of -Math::BigInt. - -There are also Math::BigInt::Scalar (primarily for testing) and -Math::BigInt::BitVect; as well as Math::BigInt::Pari and likely others. -All these can be found via L: - - use Math::BigInt lib => 'BitVect'; - - my $x = Math::BigInt->new(2); - print $x ** (1024*1024); +See L for more information. -For more benchmark results see http://bloodgate.com/perl/benchmarks.html +For more benchmark results see L. =head1 BUGS @@ -2879,8 +2908,9 @@ as 1e+308. If in doubt, convert both arguments to Math::BigInt before doing eq: $y = Math::BigInt->new($y); ok ($x,$y); # okay -There is not yet a way to get a number automatically represented in exactly -the way Perl represents it. +Alternatively, simple use <=> for comparisations, that will get it always +right. There is not yet a way to get a number automatically represented as +a string that matches exactly the way Perl represents it. =item int() @@ -3053,7 +3083,8 @@ since overload calls C instead of C. The first variant needs to preserve $x since it does not know that it later will get overwritten. This makes a copy of $x and takes O(N), but $x->bneg() is O(1). -With Copy-On-Write, this issue will be gone. Stay tuned... +With Copy-On-Write, this issue would be gone, but C-o-W is not implemented +since it is slower for all other things. =item Mixing different object types @@ -3080,7 +3111,7 @@ With overloaded math, only the first two variants will result in a BigFloat: $integer = $mbi2 / $mbf; # $mbi2->bdiv() This is because math with overloaded operators follows the first (dominating) -operand, this one's operation is called and returns thus the result. So, +operand, and the operation of that is called and returns thus the result. So, Math::BigInt::bdiv() will always return a Math::BigInt, regardless whether the result should be a Math::BigFloat or the second operant is one. @@ -3114,18 +3145,18 @@ This section also applies to other overloaded math packages, like Math::String. =item bsqrt() -C works only good if the result is an big integer, e.g. the square +C works only good if the result is a big integer, e.g. the square root of 144 is 12, but from 12 the square root is 3, regardless of rounding mode. If you want a better approximation of the square root, then use: $x = Math::BigFloat->new(12); - $Math::BigFloat::precision = 0; + Math::BigFloat->precision(0); Math::BigFloat->round_mode('even'); print $x->copy->bsqrt(),"\n"; # 4 - $Math::BigFloat::precision = 2; + Math::BigFloat->precision(2); print $x->bsqrt(),"\n"; # 3.46 print $x->bsqrt(3),"\n"; # 3.464 diff --git a/lib/Math/BigInt/Calc.pm b/lib/Math/BigInt/Calc.pm index ba7483f..9424143 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.16'; +$VERSION = '0.17'; # Package to store unsigned big integers in decimal and do math with them @@ -30,35 +30,55 @@ $VERSION = '0.16'; # constants for easier life my $nan = 'NaN'; -my ($BASE,$RBASE,$BASE_LEN,$MAX_VAL); +my ($BASE,$RBASE,$BASE_LEN,$MAX_VAL,$BASE_LEN2); +my ($AND_BITS,$XOR_BITS,$OR_BITS); +my ($AND_MASK,$XOR_MASK,$OR_MASK); sub _base_len { # set/get the BASE_LEN and assorted other, connected values # used only be the testsuite, set is used only by the BEGIN block below + shift; + my $b = shift; if (defined $b) { - $b = 8 if $b > 8; # cap, for VMS, OS/390 and other 64 bit - $BASE_LEN = $b; + $b = 5 if $^O =~ /^uts/; # UTS needs 5, because 6 and 7 break + $BASE_LEN = $b+1; + my $caught; + while (--$BASE_LEN > 5) + { + $BASE = int("1e".$BASE_LEN); + $RBASE = abs('1e-'.$BASE_LEN); # see USE_MUL + $caught = 0; + $caught += 1 if (int($BASE * $RBASE) != 1); # should be 1 + $caught += 2 if (int($BASE / $BASE) != 1); # should be 1 + # print "caught $caught\n"; + last if $caught != 3; + } $BASE = int("1e".$BASE_LEN); - $RBASE = abs('1e-'.$BASE_LEN); # see USE_MUL + $RBASE = abs('1e-'.$BASE_LEN); # see USE_MUL $MAX_VAL = $BASE-1; - # print "BASE_LEN: $BASE_LEN MAX_VAL: $MAX_VAL\n"; - # print "int: ",int($BASE * $RBASE),"\n"; - if (int($BASE * $RBASE) == 0) # should be 1 + $BASE_LEN2 = int($BASE_LEN / 2); # for mul shortcut + # print "BASE_LEN: $BASE_LEN MAX_VAL: $MAX_VAL BASE: $BASE RBASE: $RBASE\n"; + + if ($caught & 1 != 0) { # must USE_MUL *{_mul} = \&_mul_use_mul; *{_div} = \&_div_use_mul; } - else + else # $caught must be 2, since it can't be 1 nor 3 { # can USE_DIV instead *{_mul} = \&_mul_use_div; *{_div} = \&_div_use_div; } } + if (wantarray) + { + return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS); + } $BASE_LEN; } @@ -71,11 +91,50 @@ BEGIN do { $num = ('9' x ++$e) + 0; - $num *= $num + 1; + $num *= $num + 1.0; # print "$num $e\n"; - } while ("$num" =~ /9{$e}0{$e}/); # must be a certain pattern - # last test failed, so retract one step: - _base_len($e-1); + } while ("$num" =~ /9{$e}0{$e}/); # must be a certain pattern + $e--; # last test failed, so retract one step + # the limits below brush the problems with the test above under the rug: + # the test should be able to find the proper $e automatically + $e = 5 if $^O =~ /^uts/; # UTS get's some special treatment + $e = 5 if $^O =~ /^unicos/; # unicos is also problematic (6 seems to work + # there, but we play safe) + $e = 8 if $e > 8; # cap, for VMS, OS/390 and other 64 bit systems + + __PACKAGE__->_base_len($e); # 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; + + # find max bits, we will not go higher than numberofbits that fit into $BASE + # to make _and etc simpler (and faster for smaller, slower for large numbers) + my $max = 16; + while (2 ** $max < $BASE) { $max++; } + my ($x,$y,$z); + do { + $AND_BITS++; + $x = oct('0b' . '1' x $AND_BITS); $y = $x & $x; + $z = (2 ** $AND_BITS) - 1; + } while ($AND_BITS < $max && $x == $z && $y == $x); + $AND_BITS --; # retreat one step + do { + $XOR_BITS++; + $x = oct('0b' . '1' x $XOR_BITS); $y = $x ^ 0; + $z = (2 ** $XOR_BITS) - 1; + } while ($XOR_BITS < $max && $x == $z && $y == $x); + $XOR_BITS --; # retreat one step + do { + $OR_BITS++; + $x = oct('0b' . '1' x $OR_BITS); $y = $x | $x; + $z = (2 ** $OR_BITS) - 1; + } while ($OR_BITS < $max && $x == $z && $y == $x); + $OR_BITS --; # retreat one step + + # print "AND $AND_BITS XOR $XOR_BITS OR $OR_BITS\n"; } ############################################################################## @@ -83,7 +142,7 @@ BEGIN sub _new { - # (string) return ref to num_array + # (ref to string) return ref to num_array # Convert a number from string format to internal base 100000 format. # Assumes normalized value as input. my $d = $_[1]; @@ -92,6 +151,13 @@ sub _new return [ reverse(unpack("a" . ($il % $BASE_LEN+1) . ("a$BASE_LEN" x ($il / $BASE_LEN)), $$d)) ]; } + +BEGIN + { + $AND_MASK = __PACKAGE__->_new( \( 2 ** $AND_BITS )); + $XOR_MASK = __PACKAGE__->_new( \( 2 ** $XOR_BITS )); + $OR_MASK = __PACKAGE__->_new( \( 2 ** $OR_BITS )); + } sub _zero { @@ -241,23 +307,18 @@ sub _sub $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0); $j++; } # might leave leading zeros, so fix that - __strip_zeros($sx); - return $sx; + return __strip_zeros($sx); } - else + #print "case 1 (swap)\n"; + for $i (@$sx) { - #print "case 1 (swap)\n"; - for $i (@$sx) - { - last unless defined $sy->[$j] || $car; - $sy->[$j] += $BASE - if $car = (($sy->[$j] = $i-($sy->[$j]||0) - $car) < 0); - $j++; - } - # might leave leading zeros, so fix that - __strip_zeros($sy); - return $sy; + last unless defined $sy->[$j] || $car; + $sy->[$j] += $BASE + if $car = (($sy->[$j] = $i-($sy->[$j]||0) - $car) < 0); + $j++; } + # might leave leading zeros, so fix that + __strip_zeros($sy); } sub _mul_use_mul @@ -267,6 +328,16 @@ sub _mul_use_mul # modifies first arg, second need not be different from first my ($c,$xv,$yv) = @_; + # shortcut for two very short numbers + # +0 since part maybe string '00001' from new() + if ((@$xv == 1) && (@$yv == 1) + && (length($xv->[0]+0) <= $BASE_LEN2) + && (length($yv->[0]+0) <= $BASE_LEN2)) + { + $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? @@ -300,8 +371,6 @@ sub _mul_use_mul } push @$xv, @prod; __strip_zeros($xv); - # normalize (handled last to save check for $y->is_zero() - return $xv; } sub _mul_use_div @@ -311,6 +380,16 @@ sub _mul_use_div # modifies first arg, second need not be different from first my ($c,$xv,$yv) = @_; + # shortcut for two very short numbers + # +0 since part maybe string '00001' from new() + if ((@$xv == 1) && (@$yv == 1) + && (length($xv->[0]+0) <= $BASE_LEN2) + && (length($yv->[0]+0) <= $BASE_LEN2)) + { + $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? @@ -330,15 +409,12 @@ sub _mul_use_div } push @$xv, @prod; __strip_zeros($xv); - # normalize (handled last to save check for $y->is_zero() - return $xv; } sub _div_use_mul { # ref to array, ref to array, modify first array and return remainder if # in list context - # no longer handles sign my ($c,$x,$yorg) = @_; my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1); @@ -417,18 +493,19 @@ sub _div_use_mul @$x = @q; __strip_zeros($x); __strip_zeros(\@d); + _check('',$x); + _check('',\@d); return ($x,\@d); } @$x = @q; __strip_zeros($x); - return $x; + _check('',$x); } sub _div_use_div { # ref to array, ref to array, modify first array and return remainder if # in list context - # no longer handles sign my ($c,$x,$yorg) = @_; my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1); @@ -511,9 +588,193 @@ sub _div_use_div } @$x = @q; __strip_zeros($x); - return $x; } +############################################################################## +# testing + +sub _acmp + { + # internal absolute post-normalized compare (ignore signs) + # ref to array, ref to array, return <0, 0, >0 + # arrays must have at least one entry; this is not checked for + + my ($c,$cx,$cy) = @_; + + # fat 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 + + # now calculate length based on digits, not parts + $lxy = _len($c,$cx) - _len($c,$cy); # difference + return -1 if $lxy < 0; + return 1 if $lxy > 0; + + # hm, same lengths, but same contents? + my $i = 0; my $a; + # first way takes 5.49 sec instead of 4.87, but has the early out advantage + # so grep is slightly faster, but more inflexible. hm. $_ instead of $k + # yields 5.6 instead of 5.5 sec huh? + # manual way (abort if unequal, good for early ne) + my $j = scalar @$cx - 1; + while ($j >= 0) + { + last if ($a = $cx->[$j] - $cy->[$j]); $j--; + } + return 1 if $a > 0; + return -1 if $a < 0; + return 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) + #grep { $a = $_ - $cy->[$i++]; } @$cx; + #return $a; + } + +sub _len + { + # compute number of digits in bigint, minus the sign + + # int() because add/sub sometimes leaves strings (like '00005') instead of + # '5' in this place, thus causing length() to report wrong length + my $cx = $_[1]; + + return (@$cx-1)*$BASE_LEN+length(int($cx->[-1])); + } + +sub _digit + { + # return the nth digit, negative values count backward + # zero is rightmost, so _digit(123,0) will give 3 + my ($c,$x,$n) = @_; + + my $len = _len('',$x); + + $n = $len+$n if $n < 0; # -1 last, -2 second-to-last + $n = abs($n); # if negative was too big + $len--; $n = $len if $n > $len; # n to big? + + my $elem = int($n / $BASE_LEN); # which array element + my $digit = $n % $BASE_LEN; # which digit in this element + $elem = '0000'.@$x[$elem]; # get element padded with 0's + return substr($elem,-$digit-1,1); + } + +sub _zeros + { + # return amount of trailing zeros in decimal + # check each array elem in _m for having 0 at end as long as elem == 0 + # Upon finding a elem != 0, stop + my $x = $_[1]; + my $zeros = 0; my $elem; + foreach my $e (@$x) + { + if ($e != 0) + { + $elem = "$e"; # preserve x + $elem =~ s/.*?(0*$)/$1/; # strip anything not zero + $zeros *= $BASE_LEN; # elems * 5 + $zeros += CORE::length($elem); # count trailing zeros + last; # early out + } + $zeros ++; # real else branch: 50% slower! + } + return $zeros; + } + +############################################################################## +# _is_* routines + +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; + } + +sub _is_even + { + # return true if arg (BINT or num_str) is even + my $x = $_[1]; + return (!($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; + } + +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; + } + +sub __strip_zeros + { + # internal normalization function that strips leading zeros from the array + # args: ref to array + my $s = shift; + + my $cnt = scalar @$s; # get count of parts + my $i = $cnt-1; + push @$s,0 if $i < 0; # div might return empty results, so fix it + + #print "strip: cnt $cnt i $i\n"; + # '0', '3', '4', '0', '0', + # 0 1 2 3 4 + # cnt = 5, i = 4 + # i = 4 + # i = 3 + # => fcnt = cnt - i (5-2 => 3, cnt => 5-1 = 4, throw away from 4th pos) + # >= 1: skip first part (this can be zero) + while ($i > 0) { last if $s->[$i] != 0; $i--; } + $i++; splice @$s,$i if ($i < $cnt); # $i cant be 0 + $s; + } + +############################################################################### +# check routine to test internal state of corruptions + +sub _check + { + # used by the test suite + my $x = $_[1]; + + return "$x is not a reference" if !ref($x); + + # are all parts are valid? + my $i = 0; my $j = scalar @$x; my ($e,$try); + while ($i < $j) + { + $e = $x->[$i]; $e = 'undef' unless defined $e; + $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e)"; + last if $e !~ /^[+]?[0-9]+$/; + $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (stringify)"; + last if "$e" !~ /^[+]?[0-9]+$/; + $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (cat-stringify)"; + last if '' . "$e" !~ /^[+]?[0-9]+$/; + $try = ' < 0 || >= $BASE; '."($x, $e)"; + last if $e <0 || $e >= $BASE; + # this test is disabled, since new/bnorm and certain ops (like early out + # in add/sub) are allowed/expected to leave '00000' in some elements + #$try = '=~ /^00+/; '."($x, $e)"; + #last if $e =~ /^00+/; + $i++; + } + return "Illegal part '$e' at pos $i (tested: $try)" if $i < $j; + return 0; + } + + +############################################################################### +############################################################################### +# some optional routines to make BigInt faster + sub _mod { # if possible, use mod shortcut @@ -672,179 +933,204 @@ sub _pow return $cx; } -############################################################################## -# testing - -sub _acmp +sub _sqrt { - # internal absolute post-normalized compare (ignore signs) - # ref to array, ref to array, return <0, 0, >0 - # arrays must have at least one entry; this is not checked for + # square-root of $x + # ref to array, return ref to array + my ($c,$x) = @_; - my ($c,$cx, $cy) = @_; + if (scalar @$x == 1) + { + # fit's into one Perl scalar + $x->[0] = int(sqrt($x->[0])); + return $x; + } + my $y = _copy($c,$x); + my $l = [ _len($c,$x) / 2 ]; - my ($i,$a,$x,$y,$k); - # calculate length based on digits, not parts - $x = _len('',$cx); $y = _len('',$cy); - my $lxy = $x - $y; # if different in length - return -1 if $lxy < 0; - return 1 if $lxy > 0; - $i = 0; $a = 0; - # first way takes 5.49 sec instead of 4.87, but has the early out advantage - # so grep is slightly faster, but more inflexible. hm. $_ instead of $k - # yields 5.6 instead of 5.5 sec huh? - # manual way (abort if unequal, good for early ne) - my $j = scalar @$cx - 1; - while ($j >= 0) - { - # print "$cx->[$j] $cy->[$j] $a",$cx->[$j]-$cy->[$j],"\n"; - last if ($a = $cx->[$j] - $cy->[$j]); $j--; - } - return 1 if $a > 0; - return -1 if $a < 0; - return 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) - #grep { $a = $_ - $cy->[$i++]; } @$cx; - #return $a; - } + splice @$x,0; $x->[0] = 1; # keep ref($x), but modify it -sub _len - { - # compute number of digits in bigint, minus the sign - # int() because add/sub sometimes leaves strings (like '00005') instead of - # int ('5') in this place, thus causing length() to report wrong length - my $cx = $_[1]; + _lsft($c,$x,$l,10); - return (@$cx-1)*$BASE_LEN+length(int($cx->[-1])); + my $two = _two(); + my $last = _zero(); + my $lastlast = _zero(); + while (_acmp($c,$last,$x) != 0 && _acmp($c,$lastlast,$x) != 0) + { + $lastlast = _copy($c,$last); + $last = _copy($c,$x); + _add($c,$x, _div($c,_copy($c,$y),$x)); + _div($c,$x, $two ); + } + _dec($c,$x) if _acmp($c,$y,_mul($c,_copy($c,$x),$x)) < 0; # overshot? + $x; } -sub _digit - { - # return the nth digit, negative values count backward - # zero is rightmost, so _digit(123,0) will give 3 - my ($c,$x,$n) = @_; +############################################################################## +# binary stuff - my $len = _len('',$x); +sub _and + { + my ($c,$x,$y) = @_; - $n = $len+$n if $n < 0; # -1 last, -2 second-to-last - $n = abs($n); # if negative was too big - $len--; $n = $len if $n > $len; # n to big? + # the shortcut makes equal, large numbers _really_ fast, and makes only a + # very small performance drop for small numbers (e.g. something with less + # than 32 bit) Since we optimize for large numbers, this is enabled. + return $x if _acmp($c,$x,$y) == 0; # shortcut - my $elem = int($n / $BASE_LEN); # which array element - my $digit = $n % $BASE_LEN; # which digit in this element - $elem = '0000'.@$x[$elem]; # get element padded with 0's - return substr($elem,-$digit-1,1); + my $m = _one(); my ($xr,$yr); + my $mask = $AND_MASK; + + my $x1 = $x; + my $y1 = _copy($c,$y); # make copy + $x = _zero(); + my ($b,$xrr,$yrr); + use integer; + while (!_is_zero($c,$x1) && !_is_zero($c,$y1)) + { + ($x1, $xr) = _div($c,$x1,$mask); + ($y1, $yr) = _div($c,$y1,$mask); + + # make ints() from $xr, $yr + # this is when the AND_BITS are greater tahn $BASE and is slower for + # small (<256 bits) numbers, but faster for large numbers. Disabled + # due to KISS principle + +# $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) ); + _mul($c,$m,$mask); + } + $x; } -sub _zeros +sub _xor { - # return amount of trailing zeros in decimal - # check each array elem in _m for having 0 at end as long as elem == 0 - # Upon finding a elem != 0, stop - my $x = $_[1]; - my $zeros = 0; my $elem; - foreach my $e (@$x) + my ($c,$x,$y) = @_; + + return _zero() if _acmp($c,$x,$y) == 0; # shortcut (see -and) + + my $m = _one(); my ($xr,$yr); + my $mask = $XOR_MASK; + + my $x1 = $x; + my $y1 = _copy($c,$y); # make copy + $x = _zero(); + my ($b,$xrr,$yrr); + use integer; + while (!_is_zero($c,$x1) && !_is_zero($c,$y1)) { - if ($e != 0) - { - $elem = "$e"; # preserve x - $elem =~ s/.*?(0*$)/$1/; # strip anything not zero - $zeros *= $BASE_LEN; # elems * 5 - $zeros += CORE::length($elem); # count trailing zeros - last; # early out - } - $zeros ++; # real else branch: 50% slower! + ($x1, $xr) = _div($c,$x1,$mask); + ($y1, $yr) = _div($c,$y1,$mask); + # make ints() from $xr, $yr (see _and()) + #$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) ); + _mul($c,$m,$mask); } - return $zeros; + # the loop stops when the shorter of the two numbers is exhausted + # the remainder of the longer one will survive bit-by-bit, so we simple + # multiply-add it in + _add($c,$x, _mul($c, $x1, $m) ) if !_is_zero($c,$x1); + _add($c,$x, _mul($c, $y1, $m) ) if !_is_zero($c,$y1); + + $x; } -############################################################################## -# _is_* routines - -sub _is_zero +sub _or { - # return true if arg (BINT or num_str) is zero (array '+', '0') - my $x = $_[1]; - return (((scalar @$x == 1) && ($x->[0] == 0))) <=> 0; - } + my ($c,$x,$y) = @_; -sub _is_even - { - # return true if arg (BINT or num_str) is even - my $x = $_[1]; - return (!($x->[0] & 1)) <=> 0; - } + return $x if _acmp($c,$x,$y) == 0; # shortcut (see _and) -sub _is_odd - { - # return true if arg (BINT or num_str) is even - my $x = $_[1]; - return (($x->[0] & 1)) <=> 0; - } + my $m = _one(); my ($xr,$yr); + my $mask = $OR_MASK; -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; + my $x1 = $x; + my $y1 = _copy($c,$y); # make copy + $x = _zero(); + my ($b,$xrr,$yrr); + use integer; + while (!_is_zero($c,$x1) && !_is_zero($c,$y1)) + { + ($x1, $xr) = _div($c,$x1,$mask); + ($y1, $yr) = _div($c,$y1,$mask); + # make ints() from $xr, $yr (see _and()) +# $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) ); + _mul($c,$m,$mask); + } + # the loop stops when the shorter of the two numbers is exhausted + # the remainder of the longer one will survive bit-by-bit, so we simple + # multiply-add it in + _add($c,$x, _mul($c, $x1, $m) ) if !_is_zero($c,$x1); + _add($c,$x, _mul($c, $y1, $m) ) if !_is_zero($c,$y1); + + $x; } -sub __strip_zeros +sub _from_hex { - # internal normalization function that strips leading zeros from the array - # args: ref to array - my $s = shift; - - my $cnt = scalar @$s; # get count of parts - my $i = $cnt-1; - #print "strip: cnt $cnt i $i\n"; - # '0', '3', '4', '0', '0', - # 0 1 2 3 4 - # cnt = 5, i = 4 - # i = 4 - # i = 3 - # => fcnt = cnt - i (5-2 => 3, cnt => 5-1 = 4, throw away from 4th pos) - # >= 1: skip first part (this can be zero) - while ($i > 0) { last if $s->[$i] != 0; $i--; } - $i++; splice @$s,$i if ($i < $cnt); # $i cant be 0 - return $s; - } + # convert a hex number to decimal (ref to string, return ref to array) + my ($c,$hs) = @_; -############################################################################### -# check routine to test internal state of corruptions + my $mul = _one(); + my $m = [ 0x10000 ]; # 16 bit at a time + my $x = _zero(); -sub _check + my $len = CORE::length($$hs)-2; + $len = int($len/4); # 4-digit parts, w/o '0x' + my $val; my $i = -4; + while ($len >= 0) + { + $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 + $i -= 4; $len --; + _add ($c, $x, _mul ($c, [ $val ], $mul ) ) if $val != 0; + _mul ($c, $mul, $m ) if $len >= 0; # skip last mul + } + $x; + } + +sub _from_bin { - # used by the test suite - my $x = $_[1]; + # convert a hex number to decimal (ref to string, return ref to array) + my ($c,$bs) = @_; - return "$x is not a reference" if !ref($x); + my $mul = _one(); + my $m = [ 0x100 ]; # 8 bit at a time + my $x = _zero(); - # are all parts are valid? - my $i = 0; my $j = scalar @$x; my ($e,$try); - while ($i < $j) + my $len = CORE::length($$bs)-2; + $len = int($len/8); # 4-digit parts, w/o '0x' + my $val; my $i = -8; + while ($len >= 0) { - $e = $x->[$i]; $e = 'undef' unless defined $e; - $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e)"; - last if $e !~ /^[+]?[0-9]+$/; - $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (stringify)"; - last if "$e" !~ /^[+]?[0-9]+$/; - $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (cat-stringify)"; - last if '' . "$e" !~ /^[+]?[0-9]+$/; - $try = ' < 0 || >= $BASE; '."($x, $e)"; - last if $e <0 || $e >= $BASE; - # this test is disabled, since new/bnorm and certain ops (like early out - # in add/sub) are allowed/expected to leave '00000' in some elements - #$try = '=~ /^00+/; '."($x, $e)"; - #last if $e =~ /^00+/; - $i++; + $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 --; + _add ($c, $x, _mul ($c, [ $val ], $mul ) ) if $val != 0; + _mul ($c, $mul, $m ) if $len >= 0; # skip last mul } - return "Illegal part '$e' at pos $i (tested: $try)" if $i < $j; - return 0; + $x; } +############################################################################## +############################################################################## + 1; __END__ @@ -939,7 +1225,7 @@ slow) fallback routines to emulate these: _or(obj1,obj2) OR (bit-wise) object 1 with object 2 _mod(obj,obj) Return remainder of div of the 1st by the 2nd object - _sqrt(obj) return the square root of object + _sqrt(obj) return the square root of object (truncate to int) _pow(obj,obj) return object 1 to the power of object 2 _gcd(obj,obj) return Greatest Common Divisor of two objects diff --git a/lib/Math/BigInt/t/bare_mbi.t b/lib/Math/BigInt/t/bare_mbi.t new file mode 100644 index 0000000..03aed46 --- /dev/null +++ b/lib/Math/BigInt/t/bare_mbi.t @@ -0,0 +1,42 @@ +#!/usr/bin/perl -w + +use Test; +use strict; + +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 + @INC = qw(../t/lib); + } + unshift @INC, qw(../lib); # to locate the modules + 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 => 1865; + } + +use Math::BigInt lib => 'BareCalc'; + +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!) + +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 7844e72..b61af2a 100644 --- a/lib/Math/BigInt/t/bigfltpm.inc +++ b/lib/Math/BigInt/t/bigfltpm.inc @@ -54,7 +54,7 @@ while () $try .= "\$x->length();"; # some unary ops (test the bxxx form, since that is done by AUTOLOAD) } elsif ($f =~ /^f(nan|sstr|neg|floor|ceil|abs)$/) { - $try .= "\$x->b$1();"; + $try .= "\$x->f$1();"; # some is_xxx test function } elsif ($f =~ /^is_(zero|one|negative|positive|odd|even|nan)$/) { $try .= "\$x->$f();"; @@ -88,6 +88,10 @@ while () $try .= '$x * $y;'; } elsif ($f eq "fdiv") { $try .= "$setup; \$x / \$y;"; + } elsif ($f eq "frsft") { + $try .= '$x >> $y;'; + } elsif ($f eq "flsft") { + $try .= '$x << $y;'; } elsif ($f eq "fmod") { $try .= '$x % $y;'; } else { warn "Unknown op '$f'"; } @@ -128,7 +132,8 @@ while () } } # end while -# check whether new() for BigInts destroys them ($y == 12 in this case) +# check whether $class->new( Math::BigInt->new()) destroys it +# ($y == 12 in this case) $x = Math::BigInt->new(1200); $y = $class->new($x); ok ($y,1200); ok ($x,1200); @@ -141,7 +146,12 @@ ok ($x,'NaN'); ok ($y,'NaN'); $x = $class->bzero(); ($x,$y) = $x->fdiv(1); ok ($x,0); ok ($y,0); -# all done +$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}); + +1; # all done ############################################################################### # Perl 5.005 does not like ok ($x,undef) @@ -155,6 +165,21 @@ sub ok_undef } __DATA__ +&frsft +#NaNfrsft:NaN +0:2:0 +1:1:0.5 +2:1:1 +4:1:2 +123:1:61.5 +32:3:4 +&flsft +#NaNflsft:NaN +2:1:4 +4:3:32 +5:3:40 +1:2:4 +0:5:0 &fnorm 1:1 -0:0 @@ -867,6 +892,7 @@ abc:+1:abc:NaN +106500000:+339:314159.2920353982300884955752212389380531 +1000000000:+3:333333333.3333333333333333333333333333333 2:25.024996000799840031993601279744051189762:0.07992009269196593320152084692285869265447 +123456:1:123456 $div_scale = 20 +1000000000:+9:111111111.11111111111 +2000000000:+9:222222222.22222222222 @@ -883,6 +909,7 @@ $div_scale = 20 1:10000:0.0001 1:504:0.001984126984126984127 2:1.987654321:1.0062111801179738436 +123456789.123456789123456789123456789:1:123456789.12345678912 # the next two cases are the "old" behaviour, but are now (>v0.01) different #+35500000:+113:314159.292035398230088 #+71000000:+226:314159.292035398230088 @@ -893,6 +920,7 @@ $div_scale = 20 $div_scale = 1 # round to accuracy 1 after bdiv +124:+3:40 +123456789.1234:1:100000000 # reset scale for further tests $div_scale = 40 &fmod @@ -913,14 +941,18 @@ $div_scale = 40 nanfsqrt:NaN +inf:inf -inf:NaN -+1:1 -+2:1.41421356237309504880168872420969807857 -+4:2 -+16:4 -+100:10 -+123.456:11.11107555549866648462149404118219234119 -+15241.38393:123.4559999756998444766131352122991626468 -+1.44:1.2 +1:1 +2:1.41421356237309504880168872420969807857 +4:2 +9:3 +16:4 +100:10 +123.456:11.11107555549866648462149404118219234119 +15241.38393:123.4559999756998444766131352122991626468 +1.44:1.2 +# sqrt(1.44) = 1.2, sqrt(e10) = e5 => 12e4 +1.44E10:120000 +2e10:141421.356237309504880168872420969807857 &is_nan 123:0 abc:1 diff --git a/lib/Math/BigInt/t/bigfltpm.t b/lib/Math/BigInt/t/bigfltpm.t index 5fe1917..c31d7f1 100755 --- a/lib/Math/BigInt/t/bigfltpm.t +++ b/lib/Math/BigInt/t/bigfltpm.t @@ -31,7 +31,7 @@ BEGIN # unshift @INC, $location; # to locate the testing files # # chdir 't' if -d 't'; - plan tests => 1325; + plan tests => 1367; } use Math::BigInt; diff --git a/lib/Math/BigInt/t/bigintc.t b/lib/Math/BigInt/t/bigintc.t index 87006b0..05b5fcc 100644 --- a/lib/Math/BigInt/t/bigintc.t +++ b/lib/Math/BigInt/t/bigintc.t @@ -8,7 +8,7 @@ BEGIN $| = 1; chdir 't' if -d 't'; unshift @INC, '../lib'; # for running manually - plan tests => 56; + plan tests => 63; } # testing of Math::BigInt::Calc, primarily for interface/api and not for the @@ -128,6 +128,24 @@ $x = $C->_new(\$x); $C->_dec($x); ok (${$C->_str($x)},$z); # should not happen: # $x = $C->_new(\"-2"); $y = $C->_new(\"4"); ok ($C->_acmp($x,$y),-1); +# _mod +$x = $C->_new(\"1000"); $y = $C->_new(\"3"); +ok (${$C->_str(scalar $C->_mod($x,$y))},1); +$x = $C->_new(\"1000"); $y = $C->_new(\"2"); +ok (${$C->_str(scalar $C->_mod($x,$y))},0); + +# _and, _or, _xor +$x = $C->_new(\"5"); $y = $C->_new(\"2"); +ok (${$C->_str(scalar $C->_xor($x,$y))},7); +$x = $C->_new(\"5"); $y = $C->_new(\"2"); +ok (${$C->_str(scalar $C->_or($x,$y))},7); +$x = $C->_new(\"5"); $y = $C->_new(\"3"); +ok (${$C->_str(scalar $C->_and($x,$y))},1); + +# _from_hex, _from_bin +ok (${$C->_str(scalar $C->_from_hex(\"0xFf"))},255); +ok (${$C->_str(scalar $C->_from_bin(\"0b10101011"))},160+11); + # _check $x = $C->_new(\"123456789"); ok ($C->_check($x),0); diff --git a/lib/Math/BigInt/t/bigintpm.inc b/lib/Math/BigInt/t/bigintpm.inc index e85c5c3..ad55d68 100644 --- a/lib/Math/BigInt/t/bigintpm.inc +++ b/lib/Math/BigInt/t/bigintpm.inc @@ -35,7 +35,7 @@ sub _swap ############################################################################## package main; -my $CALC = $class->_core_lib(); ok ($CALC,'Math::BigInt::Calc'); +my $CALC = $class->_core_lib(); ok ($CALC,$CL); my ($f,$z,$a,$exp,@a,$m,$e,$round_mode); @@ -165,9 +165,16 @@ while () $try = "\$x = $class->new(\"$args[0]\"); \$x->digit($args[1]);"; } else { warn "Unknown op '$f'"; } } - # print "trying $try\n"; + # print "trying $try\n"; $ans1 = eval $try; - $ans =~ s/^[+]([0-9])/$1/; # remove leading '+' + # 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); @@ -399,14 +406,14 @@ $x = $class->new('+inf'); ok ($x,'inf'); ############################################################################### ############################################################################### -# the followin tests only make sense with Math::BigInt::Calc +# the followin tests only make sense with Math::BigInt::Calc or BareCalc -exit if $CALC ne 'Math::BigInt::Calc'; # for Pari et al. +exit if $CALC !~ /^Math::BigInt::(Calc|BareCalc)$/; # for Pari et al. ############################################################################### # check proper length of internal arrays -my $bl = Math::BigInt::Calc::_base_len(); +my $bl = $CL->_base_len(); my $BASE = '9' x $bl; my $MAX = $BASE; $BASE++; @@ -428,18 +435,19 @@ ok($x->numify(),-($BASE*$BASE*1+$BASE*1+1)); ############################################################################### # test bug in _digits with length($c[-1]) where $c[-1] was "00001" instead of 1 -$x = Math::BigInt->new(99998); $x++; $x++; $x++; $x++; -if ($x > 100000) { ok (1,1) } else { ok ("$x < 100000","$x > 100000"); } +$x = $class->new($BASE-2); $x++; $x++; $x++; $x++; +if ($x > $BASE) { ok (1,1) } else { ok ("$x < $BASE","$x > $BASE"); } + +$x = $class->new($BASE+3); $x++; +if ($x > $BASE) { ok (1,1) } else { ok ("$x > $BASE","$x < $BASE"); } -$x = Math::BigInt->new(100003); $x++; -$y = Math::BigInt->new(1000000); -if ($x < 1000000) { ok (1,1) } else { ok ("$x > 1000000","$x < 1000000"); } +# test for +0 instead of int(): +$x = $class->new($MAX); ok ($x->length(), length($MAX)); ############################################################################### # bug in sub where number with at least 6 trailing zeros after any op failed -$x = Math::BigInt->new(123456); $z = Math::BigInt->new(10000); $z *= 10; -$x -= $z; +$x = $class->new(123456); $z = $class->new(10000); $z *= 10; $x -= $z; ok ($z, 100000); ok ($x, 23456); @@ -449,7 +457,7 @@ ok ($x, 23456); # 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 = Math::BigInt->new($x)->bmul($y); +$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++) @@ -460,13 +468,34 @@ $y .= $bl x (3*$bl-1) . $d . '0' x $bl; ok ($x,$y); ############################################################################### +# see if mul shortcut for small numbers works + +$x = '9' x $bl; +$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 = Math::BigInt->new('-322056000'); ($x,$y) = $x->bdiv('-12882240'); +$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}); + ### all tests done ############################################################ 1; @@ -610,6 +639,7 @@ NaN:-inf: 0b1000000000000000000000000000000:1073741824 0b_101:NaN 0b1_0_1:5 +0b0_0_0_1:1 # hex input -0x0:0 0xabcdefgh:NaN @@ -619,6 +649,7 @@ NaN:-inf: -0x1234:-4660 0x12345678:305419896 0x1_2_3_4_56_78:305419896 +0xa_b_c_d_e_f:11259375 0x_123:NaN # inf input inf:inf @@ -1218,6 +1249,23 @@ abc:0:NaN -7:-4:-8 -7:4:0 -4:7:4 +# equal arguments are treated special, so also do some test with unequal ones +0xFFFF:0xFFFF:0x0xFFFF +0xFFFFFF:0xFFFFFF:0x0xFFFFFF +0xFFFFFFFF:0xFFFFFFFF:0x0xFFFFFFFF +0xFFFFFFFFFF:0xFFFFFFFFFF:0x0xFFFFFFFFFF +0xFFFFFFFFFFFF:0xFFFFFFFFFFFF:0x0xFFFFFFFFFFFF +0xF0F0:0xF0F0:0x0xF0F0 +0x0F0F:0x0F0F:0x0x0F0F +0xF0F0F0:0xF0F0F0:0x0xF0F0F0 +0x0F0F0F:0x0F0F0F:0x0x0F0F0F +0xF0F0F0F0:0xF0F0F0F0:0x0xF0F0F0F0 +0x0F0F0F0F:0x0F0F0F0F:0x0x0F0F0F0F +0xF0F0F0F0F0:0xF0F0F0F0F0:0x0xF0F0F0F0F0 +0x0F0F0F0F0F:0x0F0F0F0F0F:0x0x0F0F0F0F0F +0xF0F0F0F0F0F0:0xF0F0F0F0F0F0:0x0xF0F0F0F0F0F0 +0x0F0F0F0F0F0F:0x0F0F0F0F0F0F:0x0x0F0F0F0F0F0F +0x1F0F0F0F0F0F:0x3F0F0F0F0F0F:0x0x1F0F0F0F0F0F &bior abc:abc:NaN abc:0:NaN @@ -1232,6 +1280,38 @@ abc:0:NaN -6:-6:-6 -7:4:-3 -4:7:-1 +# equal arguments are treated special, so also do some test with unequal ones +0xFFFF:0xFFFF:0x0xFFFF +0xFFFFFF:0xFFFFFF:0x0xFFFFFF +0xFFFFFFFF:0xFFFFFFFF:0x0xFFFFFFFF +0xFFFFFFFFFF:0xFFFFFFFFFF:0x0xFFFFFFFFFF +0xFFFFFFFFFFFF:0xFFFFFFFFFFFF:0x0xFFFFFFFFFFFF +0:0xFFFF:0x0xFFFF +0:0xFFFFFF:0x0xFFFFFF +0:0xFFFFFFFF:0x0xFFFFFFFF +0:0xFFFFFFFFFF:0x0xFFFFFFFFFF +0:0xFFFFFFFFFFFF:0x0xFFFFFFFFFFFF +0xFFFF:0:0x0xFFFF +0xFFFFFF:0:0x0xFFFFFF +0xFFFFFFFF:0:0x0xFFFFFFFF +0xFFFFFFFFFF:0:0x0xFFFFFFFFFF +0xFFFFFFFFFFFF:0:0x0xFFFFFFFFFFFF +0xF0F0:0xF0F0:0x0xF0F0 +0x0F0F:0x0F0F:0x0x0F0F +0xF0F0:0x0F0F:0x0xFFFF +0xF0F0F0:0xF0F0F0:0x0xF0F0F0 +0x0F0F0F:0x0F0F0F:0x0x0F0F0F +0x0F0F0F:0xF0F0F0:0x0xFFFFFF +0xF0F0F0F0:0xF0F0F0F0:0x0xF0F0F0F0 +0x0F0F0F0F:0x0F0F0F0F:0x0x0F0F0F0F +0x0F0F0F0F:0xF0F0F0F0:0x0xFFFFFFFF +0xF0F0F0F0F0:0xF0F0F0F0F0:0x0xF0F0F0F0F0 +0x0F0F0F0F0F:0x0F0F0F0F0F:0x0x0F0F0F0F0F +0x0F0F0F0F0F:0xF0F0F0F0F0:0x0xFFFFFFFFFF +0xF0F0F0F0F0F0:0xF0F0F0F0F0F0:0x0xF0F0F0F0F0F0 +0x0F0F0F0F0F0F:0x0F0F0F0F0F0F:0x0x0F0F0F0F0F0F +0x0F0F0F0F0F0F:0xF0F0F0F0F0F0:0x0xFFFFFFFFFFFF +0x1F0F0F0F0F0F:0xF0F0F0F0F0F0:0x0xFFFFFFFFFFFF &bxor abc:abc:NaN abc:0:NaN @@ -1248,6 +1328,37 @@ abc:0:NaN -4:7:-5 4:-7:-3 -4:-7:5 +# equal arguments are treated special, so also do some test with unequal ones +0xFFFF:0xFFFF:0 +0xFFFFFF:0xFFFFFF:0 +0xFFFFFFFF:0xFFFFFFFF:0 +0xFFFFFFFFFF:0xFFFFFFFFFF:0 +0xFFFFFFFFFFFF:0xFFFFFFFFFFFF:0 +0:0xFFFF:0x0xFFFF +0:0xFFFFFF:0x0xFFFFFF +0:0xFFFFFFFF:0x0xFFFFFFFF +0:0xFFFFFFFFFF:0x0xFFFFFFFFFF +0:0xFFFFFFFFFFFF:0x0xFFFFFFFFFFFF +0xFFFF:0:0x0xFFFF +0xFFFFFF:0:0x0xFFFFFF +0xFFFFFFFF:0:0x0xFFFFFFFF +0xFFFFFFFFFF:0:0x0xFFFFFFFFFF +0xFFFFFFFFFFFF:0:0x0xFFFFFFFFFFFF +0xF0F0:0xF0F0:0 +0x0F0F:0x0F0F:0 +0xF0F0:0x0F0F:0x0xFFFF +0xF0F0F0:0xF0F0F0:0 +0x0F0F0F:0x0F0F0F:0 +0x0F0F0F:0xF0F0F0:0x0xFFFFFF +0xF0F0F0F0:0xF0F0F0F0:0 +0x0F0F0F0F:0x0F0F0F0F:0 +0x0F0F0F0F:0xF0F0F0F0:0x0xFFFFFFFF +0xF0F0F0F0F0:0xF0F0F0F0F0:0 +0x0F0F0F0F0F:0x0F0F0F0F0F:0 +0x0F0F0F0F0F:0xF0F0F0F0F0:0x0xFFFFFFFFFF +0xF0F0F0F0F0F0:0xF0F0F0F0F0F0:0 +0x0F0F0F0F0F0F:0x0F0F0F0F0F0F:0 +0x0F0F0F0F0F0F:0xF0F0F0F0F0F0:0x0xFFFFFFFFFFFF &bnot abc:NaN +0:-1 @@ -1367,18 +1478,30 @@ abc:12:NaN -123:3 215960156869840440586892398248:30 &bsqrt +145:12 144:12 +143:11 16:4 +170:13 +169:13 +168:12 4:2 +3:1 2:1 +9:3 12:3 256:16 100000000:10000 4000000000000:2000000 +152399026:12345 +152399025:12345 +152399024:12344 1:1 0:0 -2:NaN +-123:NaN Nan:NaN ++inf:NaN &bround $round_mode('trunc') 0:12:0 diff --git a/lib/Math/BigInt/t/bigintpm.t b/lib/Math/BigInt/t/bigintpm.t index 70dc726..d1fac73 100755 --- a/lib/Math/BigInt/t/bigintpm.t +++ b/lib/Math/BigInt/t/bigintpm.t @@ -10,12 +10,13 @@ BEGIN my $location = $0; $location =~ s/bigintpm.t//; unshift @INC, $location; # to locate the testing files chdir 't' if -d 't'; - plan tests => 1669; + plan tests => 1865; } use Math::BigInt; -use vars qw ($scale $class $try $x $y $f @args $ans $ans1 $ans1_str $setup); +use vars qw ($scale $class $try $x $y $f @args $ans $ans1 $ans1_str $setup $CL); $class = "Math::BigInt"; +$CL = "Math::BigInt::Calc"; require 'bigintpm.inc'; # all tests here for sharing diff --git a/lib/Math/BigInt/t/sub_mbf.t b/lib/Math/BigInt/t/sub_mbf.t index e903ac2..937a9c6 100755 --- a/lib/Math/BigInt/t/sub_mbf.t +++ b/lib/Math/BigInt/t/sub_mbf.t @@ -26,7 +26,7 @@ BEGIN } print "# INC = @INC\n"; - plan tests => 1325 + 4; # + 4 own tests + plan tests => 1367 + 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 e387f89..779416c 100755 --- a/lib/Math/BigInt/t/sub_mbi.t +++ b/lib/Math/BigInt/t/sub_mbi.t @@ -26,17 +26,19 @@ BEGIN } print "# INC = @INC\n"; - plan tests => 1669 + 4; # +4 own tests + plan tests => 1865 + + 4; # +4 own tests } use Math::BigInt::Subclass; -use vars qw ($class $try $x $y $f @args $ans $ans1 $ans1_str $setup); +use vars qw ($class $try $x $y $f @args $ans $ans1 $ans1_str $setup $CL); $class = "Math::BigInt::Subclass"; +$CL = "Math::BigInt::Calc"; -my $version = '0.01'; # for $VERSION tests, match current release (by hand!) +my $version = '0.02'; # for $VERSION tests, match current release (by hand!) -require 'bigintpm.inc'; # perform same tests as bigfltpm +require 'bigintpm.inc'; # perform same tests as bigintpm # Now do custom tests for Subclass itself my $ms = $class->new(23); diff --git a/t/lib/Math/BigFloat/Subclass.pm b/t/lib/Math/BigFloat/Subclass.pm index 7a1c279..209aa1d 100644 --- a/t/lib/Math/BigFloat/Subclass.pm +++ b/t/lib/Math/BigFloat/Subclass.pm @@ -24,9 +24,10 @@ sub new my $proto = shift; my $class = ref($proto) || $proto; - my $value = shift || 0; # Set to 0 if not provided - my $decimal = shift; - my $radix = 0; + 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; # Store the floating point value my $self = bless Math::BigFloat->new($value), $class; diff --git a/t/lib/Math/BigInt/BareCalc.pm b/t/lib/Math/BigInt/BareCalc.pm new file mode 100644 index 0000000..9cc7e94 --- /dev/null +++ b/t/lib/Math/BigInt/BareCalc.pm @@ -0,0 +1,35 @@ +package Math::BigInt::BareCalc; + +use 5.005; +use strict; +# use warnings; # dont use warnings for older Perls + +require Exporter; +use vars qw/@ISA $VERSION/; +@ISA = qw(Exporter); + +$VERSION = '0.02'; + +# Package to to test Bigint's simulation of Calc + +# uses Calc, but only features the strictly necc. methods. + +use Math::BigInt::Calc v0.17; + +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 + /) + { + my $name = "Math::BigInt::Calc::_$_"; + no strict 'refs'; + *{"Math::BigInt::BareCalc::_$_"} = \&$name; + } + } + +# catch and throw away +sub import { } + +1; diff --git a/t/lib/Math/BigInt/Subclass.pm b/t/lib/Math/BigInt/Subclass.pm index 79a4957..3656b9f 100644 --- a/t/lib/Math/BigInt/Subclass.pm +++ b/t/lib/Math/BigInt/Subclass.pm @@ -25,9 +25,8 @@ sub new my $proto = shift; my $class = ref($proto) || $proto; - my $value = shift; # no || 0 here! - my $decimal = shift; - my $radix = 0; + my $value = shift; + $value = 0 if !defined $value; # no || 0 here! # Store the floating point value my $self = bless Math::BigInt->new($value), $class; -- 2.7.4