1package Math::BigInt::Calc; 2 3use 5.006001; 4use strict; 5use warnings; 6 7use Carp qw< carp croak >; 8use Math::BigInt::Lib; 9 10our $VERSION = '1.999830'; 11$VERSION =~ tr/_//d; 12 13our @ISA = ('Math::BigInt::Lib'); 14 15# Package to store unsigned big integers in decimal and do math with them 16# 17# Internally the numbers are stored in an array with at least 1 element, no 18# leading zero parts (except the first) and in base 1eX where X is determined 19# automatically at loading time to be the maximum possible value 20# 21# todo: 22# - fully remove funky $# stuff in div() (maybe - that code scares me...) 23 24############################################################################## 25# global constants, flags and accessory 26 27# constants for easier life 28 29my $MAX_EXP_F; # the maximum possible base 10 exponent with "no integer" 30my $MAX_EXP_I; # the maximum possible base 10 exponent with "use integer" 31 32my $MAX_BITS; # the maximum possible number of bits for $AND_BITS etc. 33 34my $BASE_LEN; # the current base exponent in use 35my $USE_INT; # whether "use integer" is used in the computations 36 37my $BASE; # the current base, e.g., 10000 if $BASE_LEN is 5 38my $MAX_VAL; # maximum value for an element, i.e., $BASE - 1 39 40my $AND_BITS; # maximum value used in binary and, e.g., 0xffff 41my $OR_BITS; # ditto for binary or 42my $XOR_BITS; # ditto for binary xor 43 44my $AND_MASK; # $AND_BITS + 1, e.g., 0x10000 if $AND_BITS is 0xffff 45my $OR_MASK; # ditto for binary or 46my $XOR_MASK; # ditto for binary xor 47 48sub config { 49 my $self = shift; 50 51 croak "Missing input argument" unless @_; 52 53 # Called as a getter. 54 55 if (@_ == 1) { 56 my $param = shift; 57 croak "Parameter name must be a non-empty string" 58 unless defined $param && length $param; 59 return $BASE_LEN if $param eq 'base_len'; 60 return $USE_INT if $param eq 'use_int'; 61 croak "Unknown parameter '$param'"; 62 } 63 64 # Called as a setter. 65 66 my $opts; 67 while (@_) { 68 my $param = shift; 69 croak "Parameter name must be a non-empty string" 70 unless defined $param && length $param; 71 croak "Missing value for parameter '$param'" 72 unless @_; 73 my $value = shift; 74 75 if ($param eq 'base_len' || $param eq 'use_int') { 76 $opts -> {$param} = $value; 77 next; 78 } 79 80 croak "Unknown parameter '$param'"; 81 } 82 83 $BASE_LEN = $opts -> {base_len} if exists $opts -> {base_len}; 84 $USE_INT = $opts -> {use_int} if exists $opts -> {use_int}; 85 __PACKAGE__ -> _base_len($BASE_LEN, $USE_INT); 86 87 return $self; 88} 89 90sub _base_len { 91 #my $class = shift; # $class is not used 92 shift; 93 94 if (@_) { # if called as setter ... 95 my ($base_len, $use_int) = @_; 96 97 croak "The base length must be a positive integer" 98 unless defined($base_len) && $base_len == int($base_len) 99 && $base_len > 0; 100 101 if ( $use_int && ($base_len > $MAX_EXP_I) || 102 !$use_int && ($base_len > $MAX_EXP_F)) 103 { 104 croak "The maximum base length (exponent) is $MAX_EXP_I with", 105 " 'use integer' and $MAX_EXP_F without 'use integer'. The", 106 " requested settings, a base length of $base_len ", 107 $use_int ? "with" : "without", " 'use integer', is invalid."; 108 } 109 110 $BASE_LEN = $base_len; 111 $BASE = 0 + ("1" . ("0" x $BASE_LEN)); 112 $MAX_VAL = $BASE - 1; 113 $USE_INT = $use_int ? 1 : 0; 114 115 { 116 no warnings "redefine"; 117 if ($use_int) { 118 *_mul = \&_mul_use_int; 119 *_div = \&_div_use_int; 120 } else { 121 *_mul = \&_mul_no_int; 122 *_div = \&_div_no_int; 123 } 124 } 125 } 126 127 # Find max bits. This is the largest power of two that is both no larger 128 # than $BASE and no larger than the maximum integer (i.e., ~0). We need 129 # this limitation because _and(), _or(), and _xor() only work on one 130 # element at a time. 131 132 my $umax = ~0; # largest unsigned integer 133 my $tmp = $umax < $BASE ? $umax : $BASE; 134 135 $MAX_BITS = 0; 136 while ($tmp >>= 1) { 137 $MAX_BITS++; 138 } 139 140 # Limit to 32 bits for portability. Is this really necessary? XXX 141 142 $MAX_BITS = 32 if $MAX_BITS > 32; 143 144 # Find out how many bits _and, _or and _xor can take (old default = 16). 145 # Are these tests really necessary? Can't we just use $MAX_BITS? XXX 146 147 for ($AND_BITS = $MAX_BITS ; $AND_BITS > 0 ; $AND_BITS--) { 148 my $x = CORE::oct('0b' . '1' x $AND_BITS); 149 my $y = $x & $x; 150 my $z = 2 * (2 ** ($AND_BITS - 1)) + 1; 151 last unless $AND_BITS < $MAX_BITS && $x == $z && $y == $x; 152 } 153 154 for ($XOR_BITS = $MAX_BITS ; $XOR_BITS > 0 ; $XOR_BITS--) { 155 my $x = CORE::oct('0b' . '1' x $XOR_BITS); 156 my $y = $x ^ $x; 157 my $z = 2 * (2 ** ($XOR_BITS - 1)) + 1; 158 last unless $XOR_BITS < $MAX_BITS && $x == $z && $y == $x; 159 } 160 161 for ($OR_BITS = $MAX_BITS ; $OR_BITS > 0 ; $OR_BITS--) { 162 my $x = CORE::oct('0b' . '1' x $OR_BITS); 163 my $y = $x | $x; 164 my $z = 2 * (2 ** ($OR_BITS - 1)) + 1; 165 last unless $OR_BITS < $MAX_BITS && $x == $z && $y == $x; 166 } 167 168 $AND_MASK = __PACKAGE__->_new(( 2 ** $AND_BITS )); 169 $XOR_MASK = __PACKAGE__->_new(( 2 ** $XOR_BITS )); 170 $OR_MASK = __PACKAGE__->_new(( 2 ** $OR_BITS )); 171 172 return $BASE_LEN unless wantarray; 173 return ($BASE_LEN, $BASE, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN, $MAX_VAL, 174 $MAX_BITS, $MAX_EXP_F, $MAX_EXP_I, $USE_INT); 175} 176 177sub _new { 178 # Given a string representing an integer, returns a reference to an array 179 # of integers, where each integer represents a chunk of the original input 180 # integer. 181 182 my ($class, $str) = @_; 183 #unless ($str =~ /^([1-9]\d*|0)\z/) { 184 # croak("Invalid input string '$str'"); 185 #} 186 187 my $input_len = length($str) - 1; 188 189 # Shortcut for small numbers. 190 return bless [ $str ], $class if $input_len < $BASE_LEN; 191 192 my $format = "a" . (($input_len % $BASE_LEN) + 1); 193 $format .= $] < 5.008 ? "a$BASE_LEN" x int($input_len / $BASE_LEN) 194 : "(a$BASE_LEN)*"; 195 196 my $self = [ reverse(map { 0 + $_ } unpack($format, $str)) ]; 197 return bless $self, $class; 198} 199 200BEGIN { 201 202 # Compute $MAX_EXP_F, the maximum usable base 10 exponent. 203 204 # The largest element in base 10**$BASE_LEN is 10**$BASE_LEN-1. For instance, 205 # with $BASE_LEN = 5, the largest element is 99_999, and the largest carry is 206 # 207 # int( 99_999 * 99_999 / 100_000 ) = 99_998 208 # 209 # so make sure that 99_999 * 99_999 + 99_998 is within the range of integers 210 # that can be represented accuratly. 211 # 212 # Note that on some systems with quadmath support, the following is within 213 # the range of numbers that can be represented exactly, but it still gives 214 # the incorrect value $r = 2 (even though POSIX::fmod($x, $y) gives the 215 # correct value of 1: 216 # 217 # $x = 99999999999999999; 218 # $y = 100000000000000000; 219 # $r = $x * $x % $y; # should be 1 220 # 221 # so also check for this. 222 223 for ($MAX_EXP_F = 1 ; ; $MAX_EXP_F++) { # when $MAX_EXP_F = 5 224 my $MAX_EXP_FM1 = $MAX_EXP_F - 1; # = 4 225 my $bs = "1" . ("0" x $MAX_EXP_F); # = "100000" 226 my $xs = "9" x $MAX_EXP_F; # = "99999" 227 my $cs = ("9" x $MAX_EXP_FM1) . "8"; # = "99998" 228 my $ys = $cs . ("0" x $MAX_EXP_FM1) . "1"; # = "9999800001" 229 230 # Compute and check the product. 231 my $yn = $xs * $xs; # = 9999800001 232 last if $yn != $ys; 233 234 # Compute and check the remainder. 235 my $rn = $yn % $bs; # = 1 236 last if $rn != 1; 237 238 # Compute and check the carry. The division here is exact. 239 my $cn = ($yn - $rn) / $bs; # = 99998 240 last if $cn != $cs; 241 242 # Compute and check product plus carry. 243 my $zs = $cs . ("9" x $MAX_EXP_F); # = "9999899999" 244 my $zn = $yn + $cn; # = 99998999999 245 last if $zn != $zs; 246 last if $zn - ($zn - 1) != 1; 247 } 248 $MAX_EXP_F--; # last test failed, so retract one step 249 250 # Compute $MAX_EXP_I, the maximum usable base 10 exponent within the range 251 # of what is available with "use integer". On older versions of Perl, 252 # integers are converted to floating point numbers, even though they are 253 # within the range of what can be represented as integers. For example, on 254 # some 64 bit Perls, 999999999 * 999999999 becomes 999999998000000000, not 255 # 999999998000000001, even though the latter is less than the maximum value 256 # for a 64 bit integer, 18446744073709551615. 257 258 my $umax = ~0; # largest unsigned integer 259 for ($MAX_EXP_I = int(0.5 * log($umax) / log(10)); 260 $MAX_EXP_I > 0; 261 $MAX_EXP_I--) 262 { # when $MAX_EXP_I = 5 263 my $MAX_EXP_IM1 = $MAX_EXP_I - 1; # = 4 264 my $bs = "1" . ("0" x $MAX_EXP_I); # = "100000" 265 my $xs = "9" x $MAX_EXP_I; # = "99999" 266 my $cs = ("9" x $MAX_EXP_IM1) . "8"; # = "99998" 267 my $ys = $cs . ("0" x $MAX_EXP_IM1) . "1"; # = "9999800001" 268 269 # Compute and check the product. 270 my $yn = $xs * $xs; # = 9999800001 271 next if $yn != $ys; 272 273 # Compute and check the remainder. 274 my $rn = $yn % $bs; # = 1 275 next if $rn != 1; 276 277 # Compute and check the carry. The division here is exact. 278 my $cn = ($yn - $rn) / $bs; # = 99998 279 next if $cn != $cs; 280 281 # Compute and check product plus carry. 282 my $zs = $cs . ("9" x $MAX_EXP_I); # = "9999899999" 283 my $zn = $yn + $cn; # = 99998999999 284 next if $zn != $zs; 285 next if $zn - ($zn - 1) != 1; 286 last; 287 } 288 289 ($BASE_LEN, $USE_INT) = $MAX_EXP_F > $MAX_EXP_I 290 ? ($MAX_EXP_F, 0) : ($MAX_EXP_I, 1); 291 292 __PACKAGE__ -> _base_len($BASE_LEN, $USE_INT); 293} 294 295############################################################################### 296 297sub _zero { 298 # create a zero 299 my $class = shift; 300 return bless [ 0 ], $class; 301} 302 303sub _one { 304 # create a one 305 my $class = shift; 306 return bless [ 1 ], $class; 307} 308 309sub _two { 310 # create a two 311 my $class = shift; 312 return bless [ 2 ], $class; 313} 314 315sub _ten { 316 # create a 10 317 my $class = shift; 318 my $self = $BASE_LEN == 1 ? [ 0, 1 ] : [ 10 ]; 319 bless $self, $class; 320} 321 322sub _1ex { 323 # create a 1Ex 324 my $class = shift; 325 326 my $rem = $_[0] % $BASE_LEN; # remainder 327 my $div = ($_[0] - $rem) / $BASE_LEN; # parts 328 329 # With a $BASE_LEN of 6, 1e14 becomes 330 # [ 000000, 000000, 100 ] -> [ 0, 0, 100 ] 331 bless [ (0) x $div, 0 + ("1" . ("0" x $rem)) ], $class; 332} 333 334sub _copy { 335 # make a true copy 336 my $class = shift; 337 return bless [ @{ $_[0] } ], $class; 338} 339 340sub import { 341 my $self = shift; 342 343 my $opts; 344 my ($base_len, $use_int); 345 while (@_) { 346 my $param = shift; 347 croak "Parameter name must be a non-empty string" 348 unless defined $param && length $param; 349 croak "Missing value for parameter '$param'" 350 unless @_; 351 my $value = shift; 352 353 if ($param eq 'base_len' || $param eq 'use_int') { 354 $opts -> {$param} = $value; 355 next; 356 } 357 358 croak "Unknown parameter '$param'"; 359 } 360 361 $base_len = exists $opts -> {base_len} ? $opts -> {base_len} : $BASE_LEN; 362 $use_int = exists $opts -> {use_int} ? $opts -> {use_int} : $USE_INT; 363 __PACKAGE__ -> _base_len($base_len, $use_int); 364 365 return $self; 366} 367 368############################################################################## 369# convert back to string and number 370 371sub _str { 372 # Convert number from internal base 1eN format to string format. Internal 373 # format is always normalized, i.e., no leading zeros. 374 375 my $ary = $_[1]; 376 my $idx = $#$ary; # index of last element 377 378 if ($idx < 0) { # should not happen 379 croak("$_[1] has no elements"); 380 } 381 382 # Handle first one differently, since it should not have any leading zeros. 383 my $ret = int($ary->[$idx]); 384 if ($idx > 0) { 385 # Interestingly, the pre-padd method uses more time. 386 # The old grep variant takes longer (14 vs. 10 sec). 387 my $z = '0' x ($BASE_LEN - 1); 388 while (--$idx >= 0) { 389 $ret .= substr($z . $ary->[$idx], -$BASE_LEN); 390 } 391 } 392 $ret; 393} 394 395sub _num { 396 # Make a Perl scalar number (int/float) from a BigInt object. 397 my $x = $_[1]; 398 399 return $x->[0] if @$x == 1; # below $BASE 400 401 # Start with the most significant element and work towards the least 402 # significant element. Avoid multiplying "inf" (which happens if the number 403 # overflows) with "0" (if there are zero elements in $x) since this gives 404 # "nan" which propagates to the output. 405 406 my $num = 0; 407 for (my $i = $#$x ; $i >= 0 ; --$i) { 408 $num *= $BASE; 409 $num += $x -> [$i]; 410 } 411 return $num; 412} 413 414############################################################################## 415# actual math code 416 417sub _add { 418 # (ref to int_num_array, ref to int_num_array) 419 # 420 # Routine to add two base 1eX numbers stolen from Knuth Vol 2 Algorithm A 421 # pg 231. There are separate routines to add and sub as per Knuth pg 233. 422 # This routine modifies array x, but not y. 423 424 my ($c, $x, $y) = @_; 425 426 # $x + 0 => $x 427 428 return $x if @$y == 1 && $y->[0] == 0; 429 430 # 0 + $y => $y->copy 431 432 if (@$x == 1 && $x->[0] == 0) { 433 @$x = @$y; 434 return $x; 435 } 436 437 # For each in Y, add Y to X and carry. If after that, something is left in 438 # X, foreach in X add carry to X and then return X, carry. Trades one 439 # "$j++" for having to shift arrays. 440 441 my $car = 0; 442 my $j = 0; 443 for my $i (@$y) { 444 $x->[$j] -= $BASE if $car = (($x->[$j] += $i + $car) >= $BASE) ? 1 : 0; 445 $j++; 446 } 447 while ($car != 0) { 448 $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; 449 $j++; 450 } 451 $x; 452} 453 454sub _inc { 455 # (ref to int_num_array, ref to int_num_array) 456 # Add 1 to $x, modify $x in place 457 my ($c, $x) = @_; 458 459 for my $i (@$x) { 460 return $x if ($i += 1) < $BASE; # early out 461 $i = 0; # overflow, next 462 } 463 push @$x, 1 if $x->[-1] == 0; # last overflowed, so extend 464 $x; 465} 466 467sub _dec { 468 # (ref to int_num_array, ref to int_num_array) 469 # Sub 1 from $x, modify $x in place 470 my ($c, $x) = @_; 471 472 my $MAX = $BASE - 1; # since MAX_VAL based on BASE 473 for my $i (@$x) { 474 last if ($i -= 1) >= 0; # early out 475 $i = $MAX; # underflow, next 476 } 477 pop @$x if $x->[-1] == 0 && @$x > 1; # last underflowed (but leave 0) 478 $x; 479} 480 481sub _sub { 482 # (ref to int_num_array, ref to int_num_array, swap) 483 # 484 # Subtract base 1eX numbers -- stolen from Knuth Vol 2 pg 232, $x > $y 485 # subtract Y from X by modifying x in place 486 my ($c, $sx, $sy, $s) = @_; 487 488 my $car = 0; 489 my $j = 0; 490 if (!$s) { 491 for my $i (@$sx) { 492 last unless defined $sy->[$j] || $car; 493 $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0); 494 $j++; 495 } 496 # might leave leading zeros, so fix that 497 return __strip_zeros($sx); 498 } 499 for my $i (@$sx) { 500 # We can't do an early out if $x < $y, since we need to copy the high 501 # chunks from $y. Found by Bob Mathews. 502 #last unless defined $sy->[$j] || $car; 503 $sy->[$j] += $BASE 504 if $car = ($sy->[$j] = $i - ($sy->[$j] || 0) - $car) < 0; 505 $j++; 506 } 507 # might leave leading zeros, so fix that 508 __strip_zeros($sy); 509} 510 511sub _mul_use_int { 512 # (ref to int_num_array, ref to int_num_array) 513 # multiply two numbers in internal representation 514 # modifies first arg, second need not be different from first 515 # works for 64 bit integer with "use integer" 516 my ($c, $xv, $yv) = @_; 517 use integer; 518 519 if (@$yv == 1) { 520 # shortcut for two very short numbers (improved by Nathan Zook) works 521 # also if xv and yv are the same reference, and handles also $x == 0 522 if (@$xv == 1) { 523 if (($xv->[0] *= $yv->[0]) >= $BASE) { 524 $xv->[0] = 525 $xv->[0] - ($xv->[1] = $xv->[0] / $BASE) * $BASE; 526 } 527 return $xv; 528 } 529 # $x * 0 => 0 530 if ($yv->[0] == 0) { 531 @$xv = (0); 532 return $xv; 533 } 534 535 # multiply a large number a by a single element one, so speed up 536 my $y = $yv->[0]; 537 my $car = 0; 538 foreach my $i (@$xv) { 539 #$i = $i * $y + $car; $car = $i / $BASE; $i -= $car * $BASE; 540 $i = $i * $y + $car; 541 $i -= ($car = $i / $BASE) * $BASE; 542 } 543 push @$xv, $car if $car != 0; 544 return $xv; 545 } 546 547 # shortcut for result $x == 0 => result = 0 548 return $xv if @$xv == 1 && $xv->[0] == 0; 549 550 # since multiplying $x with $x fails, make copy in this case 551 $yv = $c->_copy($xv) if $xv == $yv; # same references? 552 553 my @prod = (); 554 my ($prod, $car, $cty); 555 for my $xi (@$xv) { 556 $car = 0; 557 $cty = 0; 558 # looping through this if $xi == 0 is silly - so optimize it away! 559 $xi = (shift(@prod) || 0), next if $xi == 0; 560 for my $yi (@$yv) { 561 $prod = $xi * $yi + ($prod[$cty] || 0) + $car; 562 $prod[$cty++] = $prod - ($car = $prod / $BASE) * $BASE; 563 } 564 $prod[$cty] += $car if $car; # need really to check for 0? 565 $xi = shift(@prod) || 0; # || 0 makes v5.005_3 happy 566 } 567 push @$xv, @prod; 568 $xv; 569} 570 571sub _mul_no_int { 572 # (ref to int_num_array, ref to int_num_array) 573 # multiply two numbers in internal representation 574 # modifies first arg, second need not be different from first 575 my ($c, $xv, $yv) = @_; 576 577 if (@$yv == 1) { 578 # shortcut for two very short numbers (improved by Nathan Zook) works 579 # also if xv and yv are the same reference, and handles also $x == 0 580 if (@$xv == 1) { 581 if (($xv->[0] *= $yv->[0]) >= $BASE) { 582 my $rem = $xv->[0] % $BASE; 583 $xv->[1] = ($xv->[0] - $rem) / $BASE; 584 $xv->[0] = $rem; 585 } 586 return $xv; 587 } 588 # $x * 0 => 0 589 if ($yv->[0] == 0) { 590 @$xv = (0); 591 return $xv; 592 } 593 594 # multiply a large number a by a single element one, so speed up 595 my $y = $yv->[0]; 596 my $car = 0; 597 my $rem; 598 foreach my $i (@$xv) { 599 $i = $i * $y + $car; 600 $rem = $i % $BASE; 601 $car = ($i - $rem) / $BASE; 602 $i = $rem; 603 } 604 push @$xv, $car if $car != 0; 605 return $xv; 606 } 607 608 # shortcut for result $x == 0 => result = 0 609 return $xv if @$xv == 1 && $xv->[0] == 0; 610 611 # since multiplying $x with $x fails, make copy in this case 612 $yv = $c->_copy($xv) if $xv == $yv; # same references? 613 614 my @prod = (); 615 my ($prod, $rem, $car, $cty); 616 for my $xi (@$xv) { 617 $car = 0; 618 $cty = 0; 619 # looping through this if $xi == 0 is silly - so optimize it away! 620 $xi = (shift(@prod) || 0), next if $xi == 0; 621 for my $yi (@$yv) { 622 $prod = $xi * $yi + ($prod[$cty] || 0) + $car; 623 $rem = $prod % $BASE; 624 $car = ($prod - $rem) / $BASE; 625 $prod[$cty++] = $rem; 626 } 627 $prod[$cty] += $car if $car; # need really to check for 0? 628 $xi = shift(@prod) || 0; # || 0 makes v5.005_3 happy 629 } 630 push @$xv, @prod; 631 $xv; 632} 633 634sub _div_use_int { 635 # ref to array, ref to array, modify first array and return remainder if 636 # in list context 637 638 # This version works on integers 639 use integer; 640 641 my ($c, $x, $yorg) = @_; 642 643 # the general div algorithm here is about O(N*N) and thus quite slow, so 644 # we first check for some special cases and use shortcuts to handle them. 645 646 # if both numbers have only one element: 647 if (@$x == 1 && @$yorg == 1) { 648 # shortcut, $yorg and $x are two small numbers 649 if (wantarray) { 650 my $rem = [ $x->[0] % $yorg->[0] ]; 651 bless $rem, $c; 652 $x->[0] = $x->[0] / $yorg->[0]; 653 return ($x, $rem); 654 } else { 655 $x->[0] = $x->[0] / $yorg->[0]; 656 return $x; 657 } 658 } 659 660 # if x has more than one, but y has only one element: 661 if (@$yorg == 1) { 662 my $rem; 663 $rem = $c->_mod($c->_copy($x), $yorg) if wantarray; 664 665 # shortcut, $y is < $BASE 666 my $j = @$x; 667 my $r = 0; 668 my $y = $yorg->[0]; 669 my $b; 670 while ($j-- > 0) { 671 $b = $r * $BASE + $x->[$j]; 672 $r = $b % $y; 673 $x->[$j] = $b / $y; 674 } 675 pop(@$x) if @$x > 1 && $x->[-1] == 0; # remove any trailing zero 676 return ($x, $rem) if wantarray; 677 return $x; 678 } 679 680 # now x and y have more than one element 681 682 # check whether y has more elements than x, if so, the result is 0 683 if (@$yorg > @$x) { 684 my $rem; 685 $rem = $c->_copy($x) if wantarray; # make copy 686 @$x = 0; # set to 0 687 return ($x, $rem) if wantarray; # including remainder? 688 return $x; # only x, which is [0] now 689 } 690 691 # check whether the numbers have the same number of elements, in that case 692 # the result will fit into one element and can be computed efficiently 693 if (@$yorg == @$x) { 694 my $cmp = 0; 695 for (my $j = $#$x ; $j >= 0 ; --$j) { 696 last if $cmp = $x->[$j] - $yorg->[$j]; 697 } 698 699 if ($cmp == 0) { # x = y 700 @$x = 1; 701 return $x, $c->_zero() if wantarray; 702 return $x; 703 } 704 705 if ($cmp < 0) { # x < y 706 if (wantarray) { 707 my $rem = $c->_copy($x); 708 @$x = 0; 709 return $x, $rem; 710 } 711 @$x = 0; 712 return $x; 713 } 714 } 715 716 # all other cases: 717 718 my $y = $c->_copy($yorg); # always make copy to preserve 719 720 my $tmp; 721 my $dd = $BASE / ($y->[-1] + 1); 722 if ($dd != 1) { 723 my $car = 0; 724 for my $xi (@$x) { 725 $xi = $xi * $dd + $car; 726 $xi -= ($car = $xi / $BASE) * $BASE; 727 } 728 push(@$x, $car); 729 $car = 0; 730 for my $yi (@$y) { 731 $yi = $yi * $dd + $car; 732 $yi -= ($car = $yi / $BASE) * $BASE; 733 } 734 } else { 735 push(@$x, 0); 736 } 737 738 # @q will accumulate the final result, $q contains the current computed 739 # part of the final result 740 741 my @q = (); 742 my ($v2, $v1) = @$y[-2, -1]; 743 $v2 = 0 unless $v2; 744 while ($#$x > $#$y) { 745 my ($u2, $u1, $u0) = @$x[-3 .. -1]; 746 $u2 = 0 unless $u2; 747 #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n" 748 # if $v1 == 0; 749 my $tmp = $u0 * $BASE + $u1; 750 my $rem = $tmp % $v1; 751 my $q = $u0 == $v1 ? $MAX_VAL : (($tmp - $rem) / $v1); 752 --$q while $v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2; 753 if ($q) { 754 my $prd; 755 my ($car, $bar) = (0, 0); 756 for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { 757 $prd = $q * $y->[$yi] + $car; 758 $prd -= ($car = int($prd / $BASE)) * $BASE; 759 $x->[$xi] += $BASE if $bar = (($x->[$xi] -= $prd + $bar) < 0); 760 } 761 if ($x->[-1] < $car + $bar) { 762 $car = 0; 763 --$q; 764 for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { 765 $x->[$xi] -= $BASE 766 if $car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE); 767 } 768 } 769 } 770 pop(@$x); 771 unshift(@q, $q); 772 } 773 774 if (wantarray) { 775 my $d = bless [], $c; 776 if ($dd != 1) { 777 my $car = 0; 778 my $prd; 779 for my $xi (reverse @$x) { 780 $prd = $car * $BASE + $xi; 781 $car = $prd - ($tmp = $prd / $dd) * $dd; 782 unshift @$d, $tmp; 783 } 784 } else { 785 @$d = @$x; 786 } 787 @$x = @q; 788 __strip_zeros($x); 789 __strip_zeros($d); 790 return ($x, $d); 791 } 792 @$x = @q; 793 __strip_zeros($x); 794 $x; 795} 796 797sub _div_no_int { 798 # ref to array, ref to array, modify first array and return remainder if 799 # in list context 800 801 my ($c, $x, $yorg) = @_; 802 803 # the general div algorithm here is about O(N*N) and thus quite slow, so 804 # we first check for some special cases and use shortcuts to handle them. 805 806 # if both numbers have only one element: 807 if (@$x == 1 && @$yorg == 1) { 808 # shortcut, $yorg and $x are two small numbers 809 my $rem = [ $x->[0] % $yorg->[0] ]; 810 bless $rem, $c; 811 $x->[0] = ($x->[0] - $rem->[0]) / $yorg->[0]; 812 return ($x, $rem) if wantarray; 813 return $x; 814 } 815 816 # if x has more than one, but y has only one element: 817 if (@$yorg == 1) { 818 my $rem; 819 $rem = $c->_mod($c->_copy($x), $yorg) if wantarray; 820 821 # shortcut, $y is < $BASE 822 my $j = @$x; 823 my $r = 0; 824 my $y = $yorg->[0]; 825 my $b; 826 while ($j-- > 0) { 827 $b = $r * $BASE + $x->[$j]; 828 $r = $b % $y; 829 $x->[$j] = ($b - $r) / $y; 830 } 831 pop(@$x) if @$x > 1 && $x->[-1] == 0; # remove any trailing zero 832 return ($x, $rem) if wantarray; 833 return $x; 834 } 835 836 # now x and y have more than one element 837 838 # check whether y has more elements than x, if so, the result is 0 839 if (@$yorg > @$x) { 840 my $rem; 841 $rem = $c->_copy($x) if wantarray; # make copy 842 @$x = 0; # set to 0 843 return ($x, $rem) if wantarray; # including remainder? 844 return $x; # only x, which is [0] now 845 } 846 847 # check whether the numbers have the same number of elements, in that case 848 # the result will fit into one element and can be computed efficiently 849 if (@$yorg == @$x) { 850 my $cmp = 0; 851 for (my $j = $#$x ; $j >= 0 ; --$j) { 852 last if $cmp = $x->[$j] - $yorg->[$j]; 853 } 854 855 if ($cmp == 0) { # x = y 856 @$x = 1; 857 return $x, $c->_zero() if wantarray; 858 return $x; 859 } 860 861 if ($cmp < 0) { # x < y 862 if (wantarray) { 863 my $rem = $c->_copy($x); 864 @$x = 0; 865 return $x, $rem; 866 } 867 @$x = 0; 868 return $x; 869 } 870 } 871 872 # all other cases: 873 874 my $y = $c->_copy($yorg); # always make copy to preserve 875 876 my $tmp = $y->[-1] + 1; 877 my $rem = $BASE % $tmp; 878 my $dd = ($BASE - $rem) / $tmp; 879 if ($dd != 1) { 880 my $car = 0; 881 for my $xi (@$x) { 882 $xi = $xi * $dd + $car; 883 $rem = $xi % $BASE; 884 $car = ($xi - $rem) / $BASE; 885 $xi = $rem; 886 } 887 push(@$x, $car); 888 $car = 0; 889 for my $yi (@$y) { 890 $yi = $yi * $dd + $car; 891 $rem = $yi % $BASE; 892 $car = ($yi - $rem) / $BASE; 893 $yi = $rem; 894 } 895 } else { 896 push(@$x, 0); 897 } 898 899 # @q will accumulate the final result, $q contains the current computed 900 # part of the final result 901 902 my @q = (); 903 my ($v2, $v1) = @$y[-2, -1]; 904 $v2 = 0 unless $v2; 905 while ($#$x > $#$y) { 906 my ($u2, $u1, $u0) = @$x[-3 .. -1]; 907 $u2 = 0 unless $u2; 908 #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n" 909 # if $v1 == 0; 910 my $tmp = $u0 * $BASE + $u1; 911 my $rem = $tmp % $v1; 912 my $q = $u0 == $v1 ? $MAX_VAL : (($tmp - $rem) / $v1); 913 --$q while $v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2; 914 if ($q) { 915 my $prd; 916 my ($car, $bar) = (0, 0); 917 for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { 918 $prd = $q * $y->[$yi] + $car; 919 $rem = $prd % $BASE; 920 $car = ($prd - $rem) / $BASE; 921 $prd -= $car * $BASE; 922 $x->[$xi] += $BASE if $bar = (($x->[$xi] -= $prd + $bar) < 0); 923 } 924 if ($x->[-1] < $car + $bar) { 925 $car = 0; 926 --$q; 927 for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { 928 $x->[$xi] -= $BASE 929 if $car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE); 930 } 931 } 932 } 933 pop(@$x); 934 unshift(@q, $q); 935 } 936 937 if (wantarray) { 938 my $d = bless [], $c; 939 if ($dd != 1) { 940 my $car = 0; 941 my ($prd, $rem); 942 for my $xi (reverse @$x) { 943 $prd = $car * $BASE + $xi; 944 $rem = $prd % $dd; 945 $tmp = ($prd - $rem) / $dd; 946 $car = $rem; 947 unshift @$d, $tmp; 948 } 949 } else { 950 @$d = @$x; 951 } 952 @$x = @q; 953 __strip_zeros($x); 954 __strip_zeros($d); 955 return ($x, $d); 956 } 957 @$x = @q; 958 __strip_zeros($x); 959 $x; 960} 961 962############################################################################## 963# testing 964 965sub _acmp { 966 # Internal absolute post-normalized compare (ignore signs) 967 # ref to array, ref to array, return <0, 0, >0 968 # Arrays must have at least one entry; this is not checked for. 969 my ($c, $cx, $cy) = @_; 970 971 # shortcut for short numbers 972 return (($cx->[0] <=> $cy->[0]) <=> 0) 973 if @$cx == 1 && @$cy == 1; 974 975 # fast comp based on number of array elements (aka pseudo-length) 976 my $lxy = (@$cx - @$cy) 977 # or length of first element if same number of elements (aka difference 0) 978 || 979 # need int() here because sometimes the last element is '00018' vs '18' 980 (length(int($cx->[-1])) - length(int($cy->[-1]))); 981 982 return -1 if $lxy < 0; # already differs, ret 983 return 1 if $lxy > 0; # ditto 984 985 # manual way (abort if unequal, good for early ne) 986 my $a; 987 my $j = @$cx; 988 while (--$j >= 0) { 989 last if $a = $cx->[$j] - $cy->[$j]; 990 } 991 $a <=> 0; 992} 993 994sub _len { 995 # compute number of digits in base 10 996 997 # int() because add/sub sometimes leaves strings (like '00005') instead of 998 # '5' in this place, thus causing length() to report wrong length 999 my $cx = $_[1]; 1000 1001 (@$cx - 1) * $BASE_LEN + length(int($cx->[-1])); 1002} 1003 1004sub _digit { 1005 # Return the nth digit. Zero is rightmost, so _digit(123, 0) gives 3. 1006 # Negative values count from the left, so _digit(123, -1) gives 1. 1007 my ($c, $x, $n) = @_; 1008 1009 my $len = _len('', $x); 1010 1011 $n += $len if $n < 0; # -1 last, -2 second-to-last 1012 1013 # Math::BigInt::Calc returns 0 if N is out of range, but this is not done 1014 # by the other backend libraries. 1015 1016 return "0" if $n < 0 || $n >= $len; # return 0 for digits out of range 1017 1018 my $elem = int($n / $BASE_LEN); # index of array element 1019 my $digit = $n % $BASE_LEN; # index of digit within the element 1020 substr("0" x $BASE_LEN . "$x->[$elem]", -1 - $digit, 1); 1021} 1022 1023sub _zeros { 1024 # Return number of trailing zeros in decimal. 1025 # Check each array element for having 0 at end as long as elem == 0 1026 # Upon finding a elem != 0, stop. 1027 1028 my $x = $_[1]; 1029 1030 return 0 if @$x == 1 && $x->[0] == 0; 1031 1032 my $zeros = 0; 1033 foreach my $elem (@$x) { 1034 if ($elem != 0) { 1035 $elem =~ /[^0](0*)\z/; 1036 $zeros += length($1); # count trailing zeros 1037 last; # early out 1038 } 1039 $zeros += $BASE_LEN; 1040 } 1041 $zeros; 1042} 1043 1044############################################################################## 1045# _is_* routines 1046 1047sub _is_zero { 1048 # return true if arg is zero 1049 @{$_[1]} == 1 && $_[1]->[0] == 0 ? 1 : 0; 1050} 1051 1052sub _is_even { 1053 # return true if arg is even 1054 $_[1]->[0] % 2 ? 0 : 1; 1055} 1056 1057sub _is_odd { 1058 # return true if arg is odd 1059 $_[1]->[0] % 2 ? 1 : 0; 1060} 1061 1062sub _is_one { 1063 # return true if arg is one 1064 @{$_[1]} == 1 && $_[1]->[0] == 1 ? 1 : 0; 1065} 1066 1067sub _is_two { 1068 # return true if arg is two 1069 @{$_[1]} == 1 && $_[1]->[0] == 2 ? 1 : 0; 1070} 1071 1072sub _is_ten { 1073 # return true if arg is ten 1074 if ($BASE_LEN == 1) { 1075 @{$_[1]} == 2 && $_[1]->[0] == 0 && $_[1]->[1] == 1 ? 1 : 0; 1076 } else { 1077 @{$_[1]} == 1 && $_[1]->[0] == 10 ? 1 : 0; 1078 } 1079} 1080 1081sub __strip_zeros { 1082 # Internal normalization function that strips leading zeros from the array. 1083 # Args: ref to array 1084 my $x = shift; 1085 1086 push @$x, 0 if @$x == 0; # div might return empty results, so fix it 1087 return $x if @$x == 1; # early out 1088 1089 #print "strip: cnt $cnt i $i\n"; 1090 # '0', '3', '4', '0', '0', 1091 # 0 1 2 3 4 1092 # cnt = 5, i = 4 1093 # i = 4 1094 # i = 3 1095 # => fcnt = cnt - i (5-2 => 3, cnt => 5-1 = 4, throw away from 4th pos) 1096 # >= 1: skip first part (this can be zero) 1097 1098 my $i = $#$x; 1099 while ($i > 0) { 1100 last if $x->[$i] != 0; 1101 $i--; 1102 } 1103 $i++; 1104 splice(@$x, $i) if $i < @$x; 1105 $x; 1106} 1107 1108############################################################################### 1109# check routine to test internal state for corruptions 1110 1111sub _check { 1112 # used by the test suite 1113 my ($class, $x) = @_; 1114 1115 my $msg = $class -> SUPER::_check($x); 1116 return $msg if $msg; 1117 1118 my $n; 1119 eval { $n = @$x }; 1120 return "Not an array reference" unless $@ eq ''; 1121 1122 return "Reference to an empty array" unless $n > 0; 1123 1124 # The following fails with Math::BigInt::FastCalc because a 1125 # Math::BigInt::FastCalc "object" is an unblessed array ref. 1126 # 1127 #return 0 unless ref($x) eq $class; 1128 1129 for (my $i = 0 ; $i <= $#$x ; ++ $i) { 1130 my $e = $x -> [$i]; 1131 1132 return "Element at index $i is undefined" 1133 unless defined $e; 1134 1135 return "Element at index $i is a '" . ref($e) . 1136 "', which is not a scalar" 1137 unless ref($e) eq ""; 1138 1139 # It would be better to use the regex /^([1-9]\d*|0)\z/, but that fails 1140 # in Math::BigInt::FastCalc, because it sometimes creates array 1141 # elements like "000000". 1142 return "Element at index $i is '$e', which does not look like an" . 1143 " normal integer" unless $e =~ /^\d+\z/; 1144 1145 return "Element at index $i is '$e', which is not smaller than" . 1146 " the base '$BASE'" if $e >= $BASE; 1147 1148 return "Element at index $i (last element) is zero" 1149 if $#$x > 0 && $i == $#$x && $e == 0; 1150 } 1151 1152 return 0; 1153} 1154 1155############################################################################### 1156 1157sub _mod { 1158 # if possible, use mod shortcut 1159 my ($c, $x, $yo) = @_; 1160 1161 # slow way since $y too big 1162 if (@$yo > 1) { 1163 my ($xo, $rem) = $c->_div($x, $yo); 1164 @$x = @$rem; 1165 return $x; 1166 } 1167 1168 my $y = $yo->[0]; 1169 1170 # if both are single element arrays 1171 if (@$x == 1) { 1172 $x->[0] %= $y; 1173 return $x; 1174 } 1175 1176 # if @$x has more than one element, but @$y is a single element 1177 my $b = $BASE % $y; 1178 if ($b == 0) { 1179 # when BASE % Y == 0 then (B * BASE) % Y == 0 1180 # (B * BASE) % $y + A % Y => A % Y 1181 # so need to consider only last element: O(1) 1182 $x->[0] %= $y; 1183 } elsif ($b == 1) { 1184 # else need to go through all elements in @$x: O(N), but loop is a bit 1185 # simplified 1186 my $r = 0; 1187 foreach (@$x) { 1188 $r = ($r + $_) % $y; # not much faster, but heh... 1189 #$r += $_ % $y; $r %= $y; 1190 } 1191 $r = 0 if $r == $y; 1192 $x->[0] = $r; 1193 } else { 1194 # else need to go through all elements in @$x: O(N) 1195 my $r = 0; 1196 my $bm = 1; 1197 foreach (@$x) { 1198 $r = ($_ * $bm + $r) % $y; 1199 $bm = ($bm * $b) % $y; 1200 1201 #$r += ($_ % $y) * $bm; 1202 #$bm *= $b; 1203 #$bm %= $y; 1204 #$r %= $y; 1205 } 1206 $r = 0 if $r == $y; 1207 $x->[0] = $r; 1208 } 1209 @$x = $x->[0]; # keep one element of @$x 1210 return $x; 1211} 1212 1213############################################################################## 1214# shifts 1215 1216sub _rsft { 1217 my ($c, $x, $n, $b) = @_; 1218 return $x if $c->_is_zero($x) || $c->_is_zero($n); 1219 1220 # For backwards compatibility, allow the base $b to be a scalar. 1221 1222 $b = $c->_new($b) unless ref $b; 1223 1224 if ($c -> _acmp($b, $c -> _ten())) { 1225 return scalar $c->_div($x, $c->_pow($c->_copy($b), $n)); 1226 } 1227 1228 # shortcut (faster) for shifting by 10) 1229 # multiples of $BASE_LEN 1230 my $dst = 0; # destination 1231 my $src = $c->_num($n); # as normal int 1232 my $xlen = (@$x - 1) * $BASE_LEN + length(int($x->[-1])); 1233 if ($src >= $xlen or ($src == $xlen and !defined $x->[1])) { 1234 # 12345 67890 shifted right by more than 10 digits => 0 1235 splice(@$x, 1); # leave only one element 1236 $x->[0] = 0; # set to zero 1237 return $x; 1238 } 1239 my $rem = $src % $BASE_LEN; # remainder to shift 1240 $src = int($src / $BASE_LEN); # source 1241 if ($rem == 0) { 1242 splice(@$x, 0, $src); # even faster, 38.4 => 39.3 1243 } else { 1244 my $len = @$x - $src; # elems to go 1245 my $vd; 1246 my $z = '0' x $BASE_LEN; 1247 $x->[ @$x ] = 0; # avoid || 0 test inside loop 1248 while ($dst < $len) { 1249 $vd = $z . $x->[$src]; 1250 $vd = substr($vd, -$BASE_LEN, $BASE_LEN - $rem); 1251 $src++; 1252 $vd = substr($z . $x->[$src], -$rem, $rem) . $vd; 1253 $vd = substr($vd, -$BASE_LEN, $BASE_LEN) if length($vd) > $BASE_LEN; 1254 $x->[$dst] = int($vd); 1255 $dst++; 1256 } 1257 splice(@$x, $dst) if $dst > 0; # kill left-over array elems 1258 pop(@$x) if $x->[-1] == 0 && @$x > 1; # kill last element if 0 1259 } # else rem == 0 1260 $x; 1261} 1262 1263sub _lsft { 1264 my ($c, $x, $n, $b) = @_; 1265 1266 return $x if $c->_is_zero($x) || $c->_is_zero($n); 1267 1268 # For backwards compatibility, allow the base $b to be a scalar. 1269 1270 $b = $c->_new($b) unless ref $b; 1271 1272 # If the base is a power of 10, use shifting, since the internal 1273 # representation is in base 10eX. 1274 1275 my $bstr = $c->_str($b); 1276 if ($bstr =~ /^1(0+)\z/) { 1277 1278 # Adjust $n so that we're shifting in base 10. Do this by multiplying 1279 # $n by the base 10 logarithm of $b: $b ** $n = 10 ** (log10($b) * $n). 1280 1281 my $log10b = length($1); 1282 $n = $c->_mul($c->_new($log10b), $n); 1283 $n = $c->_num($n); # shift-len as normal int 1284 1285 # $q is the number of places to shift the elements within the array, 1286 # and $r is the number of places to shift the values within the 1287 # elements. 1288 1289 my $r = $n % $BASE_LEN; 1290 my $q = ($n - $r) / $BASE_LEN; 1291 1292 # If we must shift the values within the elements ... 1293 1294 if ($r) { 1295 my $i = @$x; # index 1296 $x->[$i] = 0; # initialize most significant element 1297 my $z = '0' x $BASE_LEN; 1298 my $vd; 1299 while ($i >= 0) { 1300 $vd = $x->[$i]; 1301 $vd = $z . $vd; 1302 $vd = substr($vd, $r - $BASE_LEN, $BASE_LEN - $r); 1303 $vd .= $i > 0 ? substr($z . $x->[$i - 1], -$BASE_LEN, $r) 1304 : '0' x $r; 1305 $vd = substr($vd, -$BASE_LEN, $BASE_LEN) if length($vd) > $BASE_LEN; 1306 $x->[$i] = int($vd); # e.g., "0...048" -> 48 etc. 1307 $i--; 1308 } 1309 1310 pop(@$x) if $x->[-1] == 0; # if most significant element is zero 1311 } 1312 1313 # If we must shift the elements within the array ... 1314 1315 if ($q) { 1316 unshift @$x, (0) x $q; 1317 } 1318 1319 } else { 1320 $x = $c->_mul($x, $c->_pow($b, $n)); 1321 } 1322 1323 return $x; 1324} 1325 1326sub _pow { 1327 # power of $x to $y 1328 # ref to array, ref to array, return ref to array 1329 my ($c, $cx, $cy) = @_; 1330 1331 if (@$cy == 1 && $cy->[0] == 0) { 1332 splice(@$cx, 1); 1333 $cx->[0] = 1; # y == 0 => x => 1 1334 return $cx; 1335 } 1336 1337 if ((@$cx == 1 && $cx->[0] == 1) || # x == 1 1338 (@$cy == 1 && $cy->[0] == 1)) # or y == 1 1339 { 1340 return $cx; 1341 } 1342 1343 if (@$cx == 1 && $cx->[0] == 0) { 1344 splice (@$cx, 1); 1345 $cx->[0] = 0; # 0 ** y => 0 (if not y <= 0) 1346 return $cx; 1347 } 1348 1349 my $pow2 = $c->_one(); 1350 1351 my $y_bin = $c->_as_bin($cy); 1352 $y_bin =~ s/^0b//; 1353 my $len = length($y_bin); 1354 while (--$len > 0) { 1355 $c->_mul($pow2, $cx) if substr($y_bin, $len, 1) eq '1'; # is odd? 1356 $c->_mul($cx, $cx); 1357 } 1358 1359 $c->_mul($cx, $pow2); 1360 $cx; 1361} 1362 1363sub _nok { 1364 # Return binomial coefficient (n over k). 1365 # Given refs to arrays, return ref to array. 1366 # First input argument is modified. 1367 1368 my ($c, $n, $k) = @_; 1369 1370 # If k > n/2, or, equivalently, 2*k > n, compute nok(n, k) as 1371 # nok(n, n-k), to minimize the number if iterations in the loop. 1372 1373 { 1374 my $twok = $c->_mul($c->_two(), $c->_copy($k)); # 2 * k 1375 if ($c->_acmp($twok, $n) > 0) { # if 2*k > n 1376 $k = $c->_sub($c->_copy($n), $k); # k = n - k 1377 } 1378 } 1379 1380 # Example: 1381 # 1382 # / 7 \ 7! 1*2*3*4 * 5*6*7 5 * 6 * 7 6 7 1383 # | | = --------- = --------------- = --------- = 5 * - * - 1384 # \ 3 / (7-3)! 3! 1*2*3*4 * 1*2*3 1 * 2 * 3 2 3 1385 1386 if ($c->_is_zero($k)) { 1387 @$n = 1; 1388 } else { 1389 1390 # Make a copy of the original n, since we'll be modifying n in-place. 1391 1392 my $n_orig = $c->_copy($n); 1393 1394 # n = 5, f = 6, d = 2 (cf. example above) 1395 1396 $c->_sub($n, $k); 1397 $c->_inc($n); 1398 1399 my $f = $c->_copy($n); 1400 $c->_inc($f); 1401 1402 my $d = $c->_two(); 1403 1404 # while f <= n (the original n, that is) ... 1405 1406 while ($c->_acmp($f, $n_orig) <= 0) { 1407 1408 # n = (n * f / d) == 5 * 6 / 2 (cf. example above) 1409 1410 $c->_mul($n, $f); 1411 $c->_div($n, $d); 1412 1413 # f = 7, d = 3 (cf. example above) 1414 1415 $c->_inc($f); 1416 $c->_inc($d); 1417 } 1418 1419 } 1420 1421 return $n; 1422} 1423 1424sub _fac { 1425 # factorial of $x 1426 # ref to array, return ref to array 1427 my ($c, $cx) = @_; 1428 1429 # We cache the smallest values. Don't assume that a single element has a 1430 # value larger than 9 or else it won't work with a $BASE_LEN of 1. 1431 1432 if (@$cx == 1) { 1433 my @factorials = 1434 ( 1435 '1', 1436 '1', 1437 '2', 1438 '6', 1439 '24', 1440 '120', 1441 '720', 1442 '5040', 1443 '40320', 1444 '362880', 1445 ); 1446 if ($cx->[0] <= $#factorials) { 1447 my $tmp = $c -> _new($factorials[ $cx->[0] ]); 1448 @$cx = @$tmp; 1449 return $cx; 1450 } 1451 } 1452 1453 # The old code further below doesn't work for small values of $BASE_LEN. 1454 # Alas, I have not been able to (or taken the time to) decipher it, so for 1455 # the case when $BASE_LEN is small, we call the parent class. This code 1456 # works in for every value of $x and $BASE_LEN. We could use this code for 1457 # all cases, but it is a little slower than the code further below, so at 1458 # least for now we keep the code below. 1459 1460 if ($BASE_LEN <= 2) { 1461 my $tmp = $c -> SUPER::_fac($cx); 1462 @$cx = @$tmp; 1463 return $cx; 1464 } 1465 1466 # This code does not work for small values of $BASE_LEN. 1467 1468 if ((@$cx == 1) && # we do this only if $x >= 12 and $x <= 7000 1469 ($cx->[0] >= 12 && $cx->[0] < 7000)) { 1470 1471 # Calculate (k-j) * (k-j+1) ... k .. (k+j-1) * (k + j) 1472 # See http://blogten.blogspot.com/2007/01/calculating-n.html 1473 # The above series can be expressed as factors: 1474 # k * k - (j - i) * 2 1475 # We cache k*k, and calculate (j * j) as the sum of the first j odd integers 1476 1477 # This will not work when N exceeds the storage of a Perl scalar, however, 1478 # in this case the algorithm would be way too slow to terminate, anyway. 1479 1480 # As soon as the last element of $cx is 0, we split it up and remember 1481 # how many zeors we got so far. The reason is that n! will accumulate 1482 # zeros at the end rather fast. 1483 my $zero_elements = 0; 1484 1485 # If n is even, set n = n -1 1486 my $k = $c->_num($cx); 1487 my $even = 1; 1488 if (($k & 1) == 0) { 1489 $even = $k; 1490 $k --; 1491 } 1492 # set k to the center point 1493 $k = ($k + 1) / 2; 1494 # print "k $k even: $even\n"; 1495 # now calculate k * k 1496 my $k2 = $k * $k; 1497 my $odd = 1; 1498 my $sum = 1; 1499 my $i = $k - 1; 1500 # keep reference to x 1501 my $new_x = $c->_new($k * $even); 1502 @$cx = @$new_x; 1503 if ($cx->[0] == 0) { 1504 $zero_elements ++; 1505 shift @$cx; 1506 } 1507 # print STDERR "x = ", $c->_str($cx), "\n"; 1508 my $BASE2 = int(sqrt($BASE))-1; 1509 my $j = 1; 1510 while ($j <= $i) { 1511 my $m = ($k2 - $sum); 1512 $odd += 2; 1513 $sum += $odd; 1514 $j++; 1515 while ($j <= $i && ($m < $BASE2) && (($k2 - $sum) < $BASE2)) { 1516 $m *= ($k2 - $sum); 1517 $odd += 2; 1518 $sum += $odd; 1519 $j++; 1520 # print STDERR "\n k2 $k2 m $m sum $sum odd $odd\n"; sleep(1); 1521 } 1522 if ($m < $BASE) { 1523 $c->_mul($cx, [$m]); 1524 } else { 1525 $c->_mul($cx, $c->_new($m)); 1526 } 1527 if ($cx->[0] == 0) { 1528 $zero_elements ++; 1529 shift @$cx; 1530 } 1531 # print STDERR "Calculate $k2 - $sum = $m (x = ", $c->_str($cx), ")\n"; 1532 } 1533 # multiply in the zeros again 1534 unshift @$cx, (0) x $zero_elements; 1535 return $cx; 1536 } 1537 1538 # go forward until $base is exceeded limit is either $x steps (steps == 100 1539 # means a result always too high) or $base. 1540 my $steps = 100; 1541 $steps = $cx->[0] if @$cx == 1; 1542 my $r = 2; 1543 my $cf = 3; 1544 my $step = 2; 1545 my $last = $r; 1546 while ($r * $cf < $BASE && $step < $steps) { 1547 $last = $r; 1548 $r *= $cf++; 1549 $step++; 1550 } 1551 if ((@$cx == 1) && $step == $cx->[0]) { 1552 # completely done, so keep reference to $x and return 1553 $cx->[0] = $r; 1554 return $cx; 1555 } 1556 1557 # now we must do the left over steps 1558 my $n; # steps still to do 1559 if (@$cx == 1) { 1560 $n = $cx->[0]; 1561 } else { 1562 $n = $c->_copy($cx); 1563 } 1564 1565 # Set $cx to the last result below $BASE (but keep ref to $x) 1566 $cx->[0] = $last; 1567 splice (@$cx, 1); 1568 # As soon as the last element of $cx is 0, we split it up and remember 1569 # how many zeors we got so far. The reason is that n! will accumulate 1570 # zeros at the end rather fast. 1571 my $zero_elements = 0; 1572 1573 # do left-over steps fit into a scalar? 1574 if (ref $n eq 'ARRAY') { 1575 # No, so use slower inc() & cmp() 1576 # ($n is at least $BASE here) 1577 my $base_2 = int(sqrt($BASE)) - 1; 1578 #print STDERR "base_2: $base_2\n"; 1579 while ($step < $base_2) { 1580 if ($cx->[0] == 0) { 1581 $zero_elements ++; 1582 shift @$cx; 1583 } 1584 my $b = $step * ($step + 1); 1585 $step += 2; 1586 $c->_mul($cx, [$b]); 1587 } 1588 $step = [$step]; 1589 while ($c->_acmp($step, $n) <= 0) { 1590 if ($cx->[0] == 0) { 1591 $zero_elements ++; 1592 shift @$cx; 1593 } 1594 $c->_mul($cx, $step); 1595 $c->_inc($step); 1596 } 1597 } else { 1598 # Yes, so we can speed it up slightly 1599 1600 # print "# left over steps $n\n"; 1601 1602 my $base_4 = int(sqrt(sqrt($BASE))) - 2; 1603 #print STDERR "base_4: $base_4\n"; 1604 my $n4 = $n - 4; 1605 while ($step < $n4 && $step < $base_4) { 1606 if ($cx->[0] == 0) { 1607 $zero_elements ++; 1608 shift @$cx; 1609 } 1610 my $b = $step * ($step + 1); 1611 $step += 2; 1612 $b *= $step * ($step + 1); 1613 $step += 2; 1614 $c->_mul($cx, [$b]); 1615 } 1616 my $base_2 = int(sqrt($BASE)) - 1; 1617 my $n2 = $n - 2; 1618 #print STDERR "base_2: $base_2\n"; 1619 while ($step < $n2 && $step < $base_2) { 1620 if ($cx->[0] == 0) { 1621 $zero_elements ++; 1622 shift @$cx; 1623 } 1624 my $b = $step * ($step + 1); 1625 $step += 2; 1626 $c->_mul($cx, [$b]); 1627 } 1628 # do what's left over 1629 while ($step <= $n) { 1630 $c->_mul($cx, [$step]); 1631 $step++; 1632 if ($cx->[0] == 0) { 1633 $zero_elements ++; 1634 shift @$cx; 1635 } 1636 } 1637 } 1638 # multiply in the zeros again 1639 unshift @$cx, (0) x $zero_elements; 1640 $cx; # return result 1641} 1642 1643sub _log_int { 1644 # calculate integer log of $x to base $base 1645 # ref to array, ref to array - return ref to array 1646 my ($c, $x, $base) = @_; 1647 1648 # X == 0 => NaN 1649 return if @$x == 1 && $x->[0] == 0; 1650 1651 # BASE 0 or 1 => NaN 1652 return if @$base == 1 && $base->[0] < 2; 1653 1654 # X == 1 => 0 (is exact) 1655 if (@$x == 1 && $x->[0] == 1) { 1656 @$x = 0; 1657 return $x, 1; 1658 } 1659 1660 my $cmp = $c->_acmp($x, $base); 1661 1662 # X == BASE => 1 (is exact) 1663 if ($cmp == 0) { 1664 @$x = 1; 1665 return $x, 1; 1666 } 1667 1668 # 1 < X < BASE => 0 (is truncated) 1669 if ($cmp < 0) { 1670 @$x = 0; 1671 return $x, 0; 1672 } 1673 1674 my $x_org = $c->_copy($x); # preserve x 1675 1676 # Compute a guess for the result based on: 1677 # $guess = int ( length_in_base_10(X) / ( log(base) / log(10) ) ) 1678 my $len = $c->_len($x_org); 1679 my $log = log($base->[-1]) / log(10); 1680 1681 # for each additional element in $base, we add $BASE_LEN to the result, 1682 # based on the observation that log($BASE, 10) is BASE_LEN and 1683 # log(x*y) == log(x) + log(y): 1684 $log += (@$base - 1) * $BASE_LEN; 1685 1686 # calculate now a guess based on the values obtained above: 1687 my $res = $c->_new(int($len / $log)); 1688 1689 @$x = @$res; 1690 my $trial = $c->_pow($c->_copy($base), $x); 1691 my $acmp = $c->_acmp($trial, $x_org); 1692 1693 # Did we get the exact result? 1694 1695 return $x, 1 if $acmp == 0; 1696 1697 # Too small? 1698 1699 while ($acmp < 0) { 1700 $c->_mul($trial, $base); 1701 $c->_inc($x); 1702 $acmp = $c->_acmp($trial, $x_org); 1703 } 1704 1705 # Too big? 1706 1707 while ($acmp > 0) { 1708 $c->_div($trial, $base); 1709 $c->_dec($x); 1710 $acmp = $c->_acmp($trial, $x_org); 1711 } 1712 1713 return $x, 1 if $acmp == 0; # result is exact 1714 return $x, 0; # result is too small 1715} 1716 1717# for debugging: 1718use constant DEBUG => 0; 1719my $steps = 0; 1720sub steps { $steps }; 1721 1722sub _sqrt { 1723 # square-root of $x in-place 1724 1725 my ($c, $x) = @_; 1726 1727 if (@$x == 1) { 1728 # fits into one Perl scalar, so result can be computed directly 1729 $x->[0] = int(sqrt($x->[0])); 1730 return $x; 1731 } 1732 1733 # Create an initial guess for the square root. 1734 1735 my $s; 1736 if (@$x % 2) { 1737 $s = [ (0) x ((@$x - 1) / 2), int(sqrt($x->[-1])) ]; 1738 } else { 1739 $s = [ (0) x ((@$x - 2) / 2), int(sqrt($x->[-2] + $x->[-1] * $BASE)) ]; 1740 } 1741 1742 # Newton's method for the square root of y: 1743 # 1744 # x(n) * x(n) - y 1745 # x(n+1) = x(n) - ----------------- 1746 # 2 * x(n) 1747 1748 my $cmp; 1749 while (1) { 1750 my $sq = $c -> _mul($c -> _copy($s), $s); 1751 $cmp = $c -> _acmp($sq, $x); 1752 1753 # If x(n)*x(n) > y, compute 1754 # 1755 # x(n) * x(n) - y 1756 # x(n+1) = x(n) - ----------------- 1757 # 2 * x(n) 1758 1759 if ($cmp > 0) { 1760 my $num = $c -> _sub($c -> _copy($sq), $x); 1761 my $den = $c -> _mul($c -> _two(), $s); 1762 my $delta = $c -> _div($num, $den); 1763 last if $c -> _is_zero($delta); 1764 $s = $c -> _sub($s, $delta); 1765 } 1766 1767 # If x(n)*x(n) < y, compute 1768 # 1769 # y - x(n) * x(n) 1770 # x(n+1) = x(n) + ----------------- 1771 # 2 * x(n) 1772 1773 elsif ($cmp < 0) { 1774 my $num = $c -> _sub($c -> _copy($x), $sq); 1775 my $den = $c -> _mul($c -> _two(), $s); 1776 my $delta = $c -> _div($num, $den); 1777 last if $c -> _is_zero($delta); 1778 $s = $c -> _add($s, $delta); 1779 } 1780 1781 # If x(n)*x(n) = y, we have the exact result. 1782 1783 else { 1784 last; 1785 } 1786 } 1787 1788 $s = $c -> _dec($s) if $cmp > 0; # never overshoot 1789 @$x = @$s; 1790 return $x; 1791} 1792 1793sub _root { 1794 # Take n'th root of $x in place. 1795 1796 my ($c, $x, $n) = @_; 1797 1798 # Small numbers. 1799 1800 if (@$x == 1) { 1801 return $x if $x -> [0] == 0 || $x -> [0] == 1; 1802 1803 if (@$n == 1) { 1804 # Result can be computed directly. Adjust initial result for 1805 # numerical errors, e.g., int(1000**(1/3)) is 2, not 3. 1806 my $y = int($x->[0] ** (1 / $n->[0])); 1807 my $yp1 = $y + 1; 1808 $y = $yp1 if $yp1 ** $n->[0] == $x->[0]; 1809 $x->[0] = $y; 1810 return $x; 1811 } 1812 } 1813 1814 # If x <= n, the result is always (truncated to) 1. 1815 1816 if ((@$x > 1 || $x -> [0] > 0) && # if x is non-zero ... 1817 $c -> _acmp($x, $n) <= 0) # ... and x <= n 1818 { 1819 my $one = $c -> _one(); 1820 @$x = @$one; 1821 return $x; 1822 } 1823 1824 # If $n is a power of two, take sqrt($x) repeatedly, e.g., root($x, 4) = 1825 # sqrt(sqrt($x)), root($x, 8) = sqrt(sqrt(sqrt($x))). 1826 1827 my $b = $c -> _as_bin($n); 1828 if ($b =~ /0b1(0+)$/) { 1829 my $count = length($1); # 0b100 => len('00') => 2 1830 my $cnt = $count; # counter for loop 1831 unshift @$x, 0; # add one element, together with one 1832 # more below in the loop this makes 2 1833 while ($cnt-- > 0) { 1834 # 'Inflate' $x by adding one element, basically computing 1835 # $x * $BASE * $BASE. This gives us more $BASE_LEN digits for 1836 # result since len(sqrt($X)) approx == len($x) / 2. 1837 unshift @$x, 0; 1838 # Calculate sqrt($x), $x is now one element to big, again. In the 1839 # next round we make that two, again. 1840 $c -> _sqrt($x); 1841 } 1842 1843 # $x is now one element too big, so truncate result by removing it. 1844 shift @$x; 1845 1846 return $x; 1847 } 1848 1849 my $DEBUG = 0; 1850 1851 # Now the general case. This works by finding an initial guess. If this 1852 # guess is incorrect, a relatively small delta is chosen. This delta is 1853 # used to find a lower and upper limit for the correct value. The delta is 1854 # doubled in each iteration. When a lower and upper limit is found, 1855 # bisection is applied to narrow down the region until we have the correct 1856 # value. 1857 1858 # Split x into mantissa and exponent in base 10, so that 1859 # 1860 # x = xm * 10^xe, where 0 < xm < 1 and xe is an integer 1861 1862 my $x_str = $c -> _str($x); 1863 my $xm = "." . $x_str; 1864 my $xe = length($x_str); 1865 1866 # From this we compute the base 10 logarithm of x 1867 # 1868 # log_10(x) = log_10(xm) + log_10(xe^10) 1869 # = log(xm)/log(10) + xe 1870 # 1871 # and then the base 10 logarithm of y, where y = x^(1/n) 1872 # 1873 # log_10(y) = log_10(x)/n 1874 1875 my $log10x = log($xm) / log(10) + $xe; 1876 my $log10y = $log10x / $c -> _num($n); 1877 1878 # And from this we compute ym and ye, the mantissa and exponent (in 1879 # base 10) of y, where 1 < ym <= 10 and ye is an integer. 1880 1881 my $ye = int $log10y; 1882 my $ym = 10 ** ($log10y - $ye); 1883 1884 # Finally, we scale the mantissa and exponent to incraese the integer 1885 # part of ym, before building the string representing our guess of y. 1886 1887 if ($DEBUG) { 1888 print "\n"; 1889 print "xm = $xm\n"; 1890 print "xe = $xe\n"; 1891 print "log10x = $log10x\n"; 1892 print "log10y = $log10y\n"; 1893 print "ym = $ym\n"; 1894 print "ye = $ye\n"; 1895 print "\n"; 1896 } 1897 1898 my $d = $ye < 15 ? $ye : 15; 1899 $ym *= 10 ** $d; 1900 $ye -= $d; 1901 1902 my $y_str = sprintf('%.0f', $ym) . "0" x $ye; 1903 my $y = $c -> _new($y_str); 1904 1905 if ($DEBUG) { 1906 print "ym = $ym\n"; 1907 print "ye = $ye\n"; 1908 print "\n"; 1909 print "y_str = $y_str (initial guess)\n"; 1910 print "\n"; 1911 } 1912 1913 # See if our guess y is correct. 1914 1915 my $trial = $c -> _pow($c -> _copy($y), $n); 1916 my $acmp = $c -> _acmp($trial, $x); 1917 1918 if ($acmp == 0) { 1919 @$x = @$y; 1920 return $x; 1921 } 1922 1923 # Find a lower and upper limit for the correct value of y. Start off with a 1924 # delta value that is approximately the size of the accuracy of the guess. 1925 1926 my $lower; 1927 my $upper; 1928 1929 my $delta = $c -> _new("1" . ("0" x $ye)); 1930 my $two = $c -> _two(); 1931 1932 if ($acmp < 0) { 1933 $lower = $y; 1934 while ($acmp < 0) { 1935 $upper = $c -> _add($c -> _copy($lower), $delta); 1936 1937 if ($DEBUG) { 1938 print "lower = $lower\n"; 1939 print "upper = $upper\n"; 1940 print "delta = $delta\n"; 1941 print "\n"; 1942 } 1943 $acmp = $c -> _acmp($c -> _pow($c -> _copy($upper), $n), $x); 1944 if ($acmp == 0) { 1945 @$x = @$upper; 1946 return $x; 1947 } 1948 $delta = $c -> _mul($delta, $two); 1949 } 1950 } 1951 1952 elsif ($acmp > 0) { 1953 $upper = $y; 1954 while ($acmp > 0) { 1955 if ($c -> _acmp($upper, $delta) <= 0) { 1956 $lower = $c -> _zero(); 1957 last; 1958 } 1959 $lower = $c -> _sub($c -> _copy($upper), $delta); 1960 1961 if ($DEBUG) { 1962 print "lower = $lower\n"; 1963 print "upper = $upper\n"; 1964 print "delta = $delta\n"; 1965 print "\n"; 1966 } 1967 $acmp = $c -> _acmp($c -> _pow($c -> _copy($lower), $n), $x); 1968 if ($acmp == 0) { 1969 @$x = @$lower; 1970 return $x; 1971 } 1972 $delta = $c -> _mul($delta, $two); 1973 } 1974 } 1975 1976 # Use bisection to narrow down the interval. 1977 1978 my $one = $c -> _one(); 1979 { 1980 1981 $delta = $c -> _sub($c -> _copy($upper), $lower); 1982 if ($c -> _acmp($delta, $one) <= 0) { 1983 @$x = @$lower; 1984 return $x; 1985 } 1986 1987 if ($DEBUG) { 1988 print "lower = $lower\n"; 1989 print "upper = $upper\n"; 1990 print "delta = $delta\n"; 1991 print "\n"; 1992 } 1993 1994 $delta = $c -> _div($delta, $two); 1995 my $middle = $c -> _add($c -> _copy($lower), $delta); 1996 1997 $acmp = $c -> _acmp($c -> _pow($c -> _copy($middle), $n), $x); 1998 if ($acmp < 0) { 1999 $lower = $middle; 2000 } elsif ($acmp > 0) { 2001 $upper = $middle; 2002 } else { 2003 @$x = @$middle; 2004 return $x; 2005 } 2006 2007 redo; 2008 } 2009 2010 $x; 2011} 2012 2013############################################################################## 2014# binary stuff 2015 2016sub _and { 2017 my ($c, $x, $y) = @_; 2018 2019 # the shortcut makes equal, large numbers _really_ fast, and makes only a 2020 # very small performance drop for small numbers (e.g. something with less 2021 # than 32 bit) Since we optimize for large numbers, this is enabled. 2022 return $x if $c->_acmp($x, $y) == 0; # shortcut 2023 2024 my $m = $c->_one(); 2025 my ($xr, $yr); 2026 my $mask = $AND_MASK; 2027 2028 my $x1 = $c->_copy($x); 2029 my $y1 = $c->_copy($y); 2030 my $z = $c->_zero(); 2031 2032 use integer; 2033 until ($c->_is_zero($x1) || $c->_is_zero($y1)) { 2034 ($x1, $xr) = $c->_div($x1, $mask); 2035 ($y1, $yr) = $c->_div($y1, $mask); 2036 2037 $c->_add($z, $c->_mul([ 0 + $xr->[0] & 0 + $yr->[0] ], $m)); 2038 $c->_mul($m, $mask); 2039 } 2040 2041 @$x = @$z; 2042 return $x; 2043} 2044 2045sub _xor { 2046 my ($c, $x, $y) = @_; 2047 2048 return $c->_zero() if $c->_acmp($x, $y) == 0; # shortcut (see -and) 2049 2050 my $m = $c->_one(); 2051 my ($xr, $yr); 2052 my $mask = $XOR_MASK; 2053 2054 my $x1 = $c->_copy($x); 2055 my $y1 = $c->_copy($y); # make copy 2056 my $z = $c->_zero(); 2057 2058 use integer; 2059 until ($c->_is_zero($x1) || $c->_is_zero($y1)) { 2060 ($x1, $xr) = $c->_div($x1, $mask); 2061 ($y1, $yr) = $c->_div($y1, $mask); 2062 # make ints() from $xr, $yr (see _and()) 2063 #$b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; } 2064 #$b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; } 2065 #$c->_add($x, $c->_mul($c->_new($xrr ^ $yrr)), $m) ); 2066 2067 $c->_add($z, $c->_mul([ 0 + $xr->[0] ^ 0 + $yr->[0] ], $m)); 2068 $c->_mul($m, $mask); 2069 } 2070 # the loop stops when the shorter of the two numbers is exhausted 2071 # the remainder of the longer one will survive bit-by-bit, so we simple 2072 # multiply-add it in 2073 $c->_add($z, $c->_mul($x1, $m) ) if !$c->_is_zero($x1); 2074 $c->_add($z, $c->_mul($y1, $m) ) if !$c->_is_zero($y1); 2075 2076 @$x = @$z; 2077 return $x; 2078} 2079 2080sub _or { 2081 my ($c, $x, $y) = @_; 2082 2083 return $x if $c->_acmp($x, $y) == 0; # shortcut (see _and) 2084 2085 my $m = $c->_one(); 2086 my ($xr, $yr); 2087 my $mask = $OR_MASK; 2088 2089 my $x1 = $c->_copy($x); 2090 my $y1 = $c->_copy($y); # make copy 2091 my $z = $c->_zero(); 2092 2093 use integer; 2094 until ($c->_is_zero($x1) || $c->_is_zero($y1)) { 2095 ($x1, $xr) = $c->_div($x1, $mask); 2096 ($y1, $yr) = $c->_div($y1, $mask); 2097 # make ints() from $xr, $yr (see _and()) 2098 # $b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; } 2099 # $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; } 2100 # $c->_add($x, $c->_mul(_new( $c, ($xrr | $yrr) ), $m) ); 2101 $c->_add($z, $c->_mul([ 0 + $xr->[0] | 0 + $yr->[0] ], $m)); 2102 $c->_mul($m, $mask); 2103 } 2104 # the loop stops when the shorter of the two numbers is exhausted 2105 # the remainder of the longer one will survive bit-by-bit, so we simple 2106 # multiply-add it in 2107 $c->_add($z, $c->_mul($x1, $m) ) if !$c->_is_zero($x1); 2108 $c->_add($z, $c->_mul($y1, $m) ) if !$c->_is_zero($y1); 2109 2110 @$x = @$z; 2111 return $x; 2112} 2113 2114sub _as_hex { 2115 # convert a decimal number to hex (ref to array, return ref to string) 2116 my ($c, $x) = @_; 2117 2118 return "0x0" if @$x == 1 && $x->[0] == 0; 2119 2120 my $x1 = $c->_copy($x); 2121 2122 my $x10000 = [ 0x10000 ]; 2123 2124 my $es = ''; 2125 my $xr; 2126 until (@$x1 == 1 && $x1->[0] == 0) { # _is_zero() 2127 ($x1, $xr) = $c->_div($x1, $x10000); 2128 $es = sprintf('%04x', $xr->[0]) . $es; 2129 } 2130 #$es = reverse $es; 2131 $es =~ s/^0*/0x/; 2132 return $es; 2133} 2134 2135sub _as_bin { 2136 # convert a decimal number to bin (ref to array, return ref to string) 2137 my ($c, $x) = @_; 2138 2139 return "0b0" if @$x == 1 && $x->[0] == 0; 2140 2141 my $x1 = $c->_copy($x); 2142 2143 my $x10000 = [ 0x10000 ]; 2144 2145 my $es = ''; 2146 my $xr; 2147 2148 until (@$x1 == 1 && $x1->[0] == 0) { # _is_zero() 2149 ($x1, $xr) = $c->_div($x1, $x10000); 2150 $es = sprintf('%016b', $xr->[0]) . $es; 2151 } 2152 $es =~ s/^0*/0b/; 2153 return $es; 2154} 2155 2156sub _as_oct { 2157 # convert a decimal number to octal (ref to array, return ref to string) 2158 my ($c, $x) = @_; 2159 2160 return "00" if @$x == 1 && $x->[0] == 0; 2161 2162 my $x1 = $c->_copy($x); 2163 2164 my $x1000 = [ 1 << 15 ]; # 15 bits = 32768 = 0100000 2165 2166 my $es = ''; 2167 my $xr; 2168 until (@$x1 == 1 && $x1->[0] == 0) { # _is_zero() 2169 ($x1, $xr) = $c->_div($x1, $x1000); 2170 $es = sprintf("%05o", $xr->[0]) . $es; 2171 } 2172 $es =~ s/^0*/0/; # excactly one leading zero 2173 return $es; 2174} 2175 2176sub _from_oct { 2177 # convert a octal number to decimal (string, return ref to array) 2178 my ($c, $os) = @_; 2179 2180 my $m = $c->_new(1 << 30); # 30 bits at a time (<32 bits!) 2181 my $d = 10; # 10 octal digits at a time 2182 2183 my $mul = $c->_one(); 2184 my $x = $c->_zero(); 2185 2186 my $len = int((length($os) - 1) / $d); # $d digit parts, w/o the '0' 2187 my $val; 2188 my $i = -$d; 2189 while ($len >= 0) { 2190 $val = substr($os, $i, $d); # get oct digits 2191 $val = CORE::oct($val); 2192 $i -= $d; 2193 $len --; 2194 my $adder = $c -> _new($val); 2195 $c->_add($x, $c->_mul($adder, $mul)) if $val != 0; 2196 $c->_mul($mul, $m) if $len >= 0; # skip last mul 2197 } 2198 $x; 2199} 2200 2201sub _from_hex { 2202 # convert a hex number to decimal (string, return ref to array) 2203 my ($c, $hs) = @_; 2204 2205 my $m = $c->_new(0x10000000); # 28 bit at a time (<32 bit!) 2206 my $d = 7; # 7 hexadecimal digits at a time 2207 my $mul = $c->_one(); 2208 my $x = $c->_zero(); 2209 2210 my $len = int((length($hs) - 2) / $d); # $d digit parts, w/o the '0x' 2211 my $val; 2212 my $i = -$d; 2213 while ($len >= 0) { 2214 $val = substr($hs, $i, $d); # get hex digits 2215 $val =~ s/^0x// if $len == 0; # for last part only because 2216 $val = CORE::hex($val); # hex does not like wrong chars 2217 $i -= $d; 2218 $len --; 2219 my $adder = $c->_new($val); 2220 # if the resulting number was to big to fit into one element, create a 2221 # two-element version (bug found by Mark Lakata - Thanx!) 2222 if (CORE::length($val) > $BASE_LEN) { 2223 $adder = $c->_new($val); 2224 } 2225 $c->_add($x, $c->_mul($adder, $mul)) if $val != 0; 2226 $c->_mul($mul, $m) if $len >= 0; # skip last mul 2227 } 2228 $x; 2229} 2230 2231sub _from_bin { 2232 # convert a hex number to decimal (string, return ref to array) 2233 my ($c, $bs) = @_; 2234 2235 # instead of converting X (8) bit at a time, it is faster to "convert" the 2236 # number to hex, and then call _from_hex. 2237 2238 my $hs = $bs; 2239 $hs =~ s/^[+-]?0b//; # remove sign and 0b 2240 my $l = length($hs); # bits 2241 $hs = '0' x (8 - ($l % 8)) . $hs if ($l % 8) != 0; # padd left side w/ 0 2242 my $h = '0x' . unpack('H*', pack ('B*', $hs)); # repack as hex 2243 2244 $c->_from_hex($h); 2245} 2246 2247############################################################################## 2248# special modulus functions 2249 2250sub _modinv { 2251 # modular multiplicative inverse 2252 my ($c, $x, $y) = @_; 2253 2254 # modulo zero 2255 if ($c->_is_zero($y)) { 2256 return; 2257 } 2258 2259 # modulo one 2260 if ($c->_is_one($y)) { 2261 return $c->_zero(), '+'; 2262 } 2263 2264 my $u = $c->_zero(); 2265 my $v = $c->_one(); 2266 my $a = $c->_copy($y); 2267 my $b = $c->_copy($x); 2268 2269 # Euclid's Algorithm for bgcd(), only that we calc bgcd() ($a) and the result 2270 # ($u) at the same time. See comments in BigInt for why this works. 2271 my $q; 2272 my $sign = 1; 2273 { 2274 ($a, $q, $b) = ($b, $c->_div($a, $b)); # step 1 2275 last if $c->_is_zero($b); 2276 2277 my $t = $c->_add( # step 2: 2278 $c->_mul($c->_copy($v), $q), # t = v * q 2279 $u); # + u 2280 $u = $v; # u = v 2281 $v = $t; # v = t 2282 $sign = -$sign; 2283 redo; 2284 } 2285 2286 # if the gcd is not 1, then return NaN 2287 return unless $c->_is_one($a); 2288 2289 ($v, $sign == 1 ? '+' : '-'); 2290} 2291 2292sub _modpow { 2293 # modulus of power ($x ** $y) % $z 2294 my ($c, $num, $exp, $mod) = @_; 2295 2296 # a^b (mod 1) = 0 for all a and b 2297 if ($c->_is_one($mod)) { 2298 @$num = 0; 2299 return $num; 2300 } 2301 2302 # 0^a (mod m) = 0 if m != 0, a != 0 2303 # 0^0 (mod m) = 1 if m != 0 2304 if ($c->_is_zero($num)) { 2305 if ($c->_is_zero($exp)) { 2306 @$num = 1; 2307 } else { 2308 @$num = 0; 2309 } 2310 return $num; 2311 } 2312 2313 # $num = $c->_mod($num, $mod); # this does not make it faster 2314 2315 my $acc = $c->_copy($num); 2316 my $t = $c->_one(); 2317 2318 my $expbin = $c->_as_bin($exp); 2319 $expbin =~ s/^0b//; 2320 my $len = length($expbin); 2321 while (--$len >= 0) { 2322 if (substr($expbin, $len, 1) eq '1') { # is_odd 2323 $t = $c->_mul($t, $acc); 2324 $t = $c->_mod($t, $mod); 2325 } 2326 $acc = $c->_mul($acc, $acc); 2327 $acc = $c->_mod($acc, $mod); 2328 } 2329 @$num = @$t; 2330 $num; 2331} 2332 2333sub _gcd { 2334 # Greatest common divisor. 2335 2336 my ($c, $x, $y) = @_; 2337 2338 # gcd(0, 0) = 0 2339 # gcd(0, a) = a, if a != 0 2340 2341 if (@$x == 1 && $x->[0] == 0) { 2342 if (@$y == 1 && $y->[0] == 0) { 2343 @$x = 0; 2344 } else { 2345 @$x = @$y; 2346 } 2347 return $x; 2348 } 2349 2350 # Until $y is zero ... 2351 2352 until (@$y == 1 && $y->[0] == 0) { 2353 2354 # Compute remainder. 2355 2356 $c->_mod($x, $y); 2357 2358 # Swap $x and $y. 2359 2360 my $tmp = $c->_copy($x); 2361 @$x = @$y; 2362 $y = $tmp; # no deref here; that would modify input $y 2363 } 2364 2365 return $x; 2366} 2367 23681; 2369 2370=pod 2371 2372=head1 NAME 2373 2374Math::BigInt::Calc - pure Perl module to support Math::BigInt 2375 2376=head1 SYNOPSIS 2377 2378 # to use it with Math::BigInt 2379 use Math::BigInt lib => 'Calc'; 2380 2381 # to use it with Math::BigFloat 2382 use Math::BigFloat lib => 'Calc'; 2383 2384 # to use it with Math::BigRat 2385 use Math::BigRat lib => 'Calc'; 2386 2387 # explicitly set base length and whether to "use integer" 2388 use Math::BigInt::Calc base_len => 4, use_int => 1; 2389 use Math::BigInt lib => 'Calc'; 2390 2391=head1 DESCRIPTION 2392 2393Math::BigInt::Calc inherits from Math::BigInt::Lib. 2394 2395In this library, the numbers are represented interenally in base B = 10**N, 2396where N is the largest possible integer that does not cause overflow in the 2397intermediate computations. The base B elements are stored in an array, with the 2398least significant element stored in array element zero. There are no leading 2399zero elements, except a single zero element when the number is zero. For 2400instance, if B = 10000, the number 1234567890 is represented internally as 2401[7890, 3456, 12]. 2402 2403=head1 OPTIONS 2404 2405When the module is loaded, it computes the maximum exponent, i.e., power of 10, 2406that can be used with and without "use integer" in the computations. The default 2407is to use this maximum exponent. If the combination of the 'base_len' value and 2408the 'use_int' value exceeds the maximum value, an error is thrown. 2409 2410=over 4 2411 2412=item base_len 2413 2414The base length can be specified explicitly with the 'base_len' option. The 2415value must be a positive integer. 2416 2417 use Math::BigInt::Calc base_len => 4; # use 10000 as internal base 2418 2419=item use_int 2420 2421This option is used to specify whether "use integer" should be used in the 2422internal computations. The value is interpreted as a boolean value, so use 0 or 2423"" for false and anything else for true. If the 'base_len' is not specified 2424together with 'use_int', the current value for the base length is used. 2425 2426 use Math::BigInt::Calc use_int => 1; # use "use integer" internally 2427 2428=back 2429 2430=head1 METHODS 2431 2432This overview constains only the methods that are specific to 2433C<Math::BigInt::Calc>. For the other methods, see L<Math::BigInt::Lib>. 2434 2435=over 4 2436 2437=item _base_len() 2438 2439Specify the desired base length and whether to enable "use integer" in the 2440computations. 2441 2442 Math::BigInt::Calc -> _base_len($base_len, $use_int); 2443 2444Note that it is better to specify the base length and whether to use integers as 2445options when the module is loaded, for example like this 2446 2447 use Math::BigInt::Calc base_len => 6, use_int => 1; 2448 2449=back 2450 2451=head1 SEE ALSO 2452 2453L<Math::BigInt::Lib> for a description of the API. 2454 2455Alternative libraries L<Math::BigInt::FastCalc>, L<Math::BigInt::GMP>, 2456L<Math::BigInt::Pari>, L<Math::BigInt::GMPz>, and L<Math::BigInt::BitVect>. 2457 2458Some of the modules that use these libraries L<Math::BigInt>, 2459L<Math::BigFloat>, and L<Math::BigRat>. 2460 2461=cut 2462