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
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/;
# 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
# _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))
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
$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
$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
$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;
}
$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;
}
$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 '-')
{
# 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;
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
$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
# (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$/;
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
}
# 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
{
# (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
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
&& ($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;
}
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
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()
$x->{_e}->bzero();
$x-- if $x->{sign} eq '-';
}
- return $x->round($a,$p,$r);
+ $x->round($a,$p,$r);
}
sub bceil
$x->{_e}->bzero();
$x++ if $x->{sign} eq '+';
}
- return $x->round($a,$p,$r);
+ $x->round($a,$p,$r);
}
sub brsft
my $m = $x->{_m}->copy(); # faster than going via bstr()
$m->bneg() if $x->{sign} eq '-';
- return $m;
+ $m;
}
sub parts
# '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
$z->blsft($x->{_e},10);
}
$z->{sign} = $x->{sign};
- return $z;
+ $z;
}
sub length
$t = $x->{_e}->copy()->babs() if $x->{_e}->sign() eq '-';
return ($len,$t);
}
- return $len;
+ $len;
}
1;
$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
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;
$_[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(); },
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'
}
else # normal ref
{
- my $xk = $x->{$k};
+ my $xk = $x->{$k};
if ($xk->can('copy'))
{
$self->{$k} = $xk->copy();
# 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$/)
$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;
}
{
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;
{
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';
{
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;
}
{
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;
}
{
# 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
{
# 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} !~ /^[+-]$/))
{
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
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
$x->{sign} = $sx;
}
}
- return $x->round(@bn);
+ $x->round(@r);
}
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
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
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
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
{
# 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$/))
{
$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
{
# (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
# 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;
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};
{
$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'))
{
$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
# (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
$x->bmul($x);
}
$x->bmul($pow2) unless $pow2->is_one();
- return $x->round($a,$p,$r);
+ return $x->round(@r);
}
sub blsft
# 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!
}
# no-op for BigInts if $n <= 0
if ($scale <= 0)
{
+ $x->{_a} = undef; # clear an eventual set A
$x->{_p} = $scale; return $x;
}
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);
# 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;
}
$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";
($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)
#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])
{
{
# 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)
{
while ($count > 0)
{
- #print "$count\n";
$count--;
$k = shift;
-# print "$k (",ref($k),") => \n";
if (!ref($k))
{
$k = $a[0]->new($k);
# 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;
}
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++ )
{
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;
}
# 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().
}
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
$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
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;
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);
}
}
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
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
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
# 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
{
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
*{_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
{
$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:
# 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;
} 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
{
# 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)) ];
}
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
# 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);
$ret .= substr($z.$ar->[$l],-$BASE_LEN); # fastest way I could think of
$l--;
}
- return \$ret;
+ \$ret;
}
sub _num
{
$num += $fac*$_; $fac *= $BASE;
}
- return $num;
+ $num;
}
##############################################################################
{
$x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; $j++;
}
- return $x;
+ $x;
}
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
# 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
# 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))
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;
# {
# $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;
## 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
# 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))
$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;
{
$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
# 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
$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));
}
}
}
$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);
}
@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
# 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
$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)
{
$car = 0;
for $xi (reverse @$x)
{
- $prd = $car * $BASE + $xi;
+ $prd = $car * $MBASE + $xi;
$car = $prd - ($tmp = int($prd / $dd)) * $dd;
unshift(@d, $tmp);
}
@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;
}
##############################################################################
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
}
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)
$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;
}
##############################################################################
{
# 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
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
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)
{
$x->[0] = $r;
}
splice (@$x,1);
- return $x;
+ $x;
}
##############################################################################
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;
}
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;
}
_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
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();
# $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;
#$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
# $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
$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)
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)
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)
$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 --;
$| = 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
}
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
$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") {
###############################################################################
# fdiv() in list context
+
$x = $class->bzero(); ($x,$y) = $x->fdiv(0);
ok ($x,'NaN'); ok ($y,'NaN');
$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
}
__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
# 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
# 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
}
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;
$| = 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);
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");
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;
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/);
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]);
{
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]);
}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;
$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));
###############################################################################
# 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
# 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
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
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
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
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
-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
+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
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
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
-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
+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
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
-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
-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
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
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
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
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
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;
--- /dev/null
+# 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 (<DATA>)
+ {
+ 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
# 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');
--- /dev/null
+#!/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;
+
}
print "# INC = @INC\n";
- plan tests => 1367 + 4; # + 4 own tests
+ plan tests => 1528
+ + 4; # + 4 own tests
}
use Math::BigFloat::Subclass;
}
print "# INC = @INC\n";
- plan tests => 1865
+ plan tests => 2005
+ 4; # +4 own tests
}
--- /dev/null
+#!/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';
+
--- /dev/null
+#!/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;
+
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;
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;
}
# 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::_$_";
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;
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;
}
sub import
{
my $self = shift;
-# Math::BigInt->import(@_);
$self->SUPER::import(@_); # need it for subclasses
#$self->export_to_level(1,$self,@_); # need this ?
}
projects / p5sagit/p5-mst-13.2.git / commitdiff