File Coverage

blib/lib/Math/BigInt/Calc.pm
Criterion Covered Total %
statement 877 1157 75.8
branch 344 524 65.6
condition 149 235 63.4
subroutine 63 67 94.0
pod 0 2 0.0
total 1433 1985 72.1


line stmt bran cond sub pod time code
1             package Math::BigInt::Calc;
2              
3 51     51   150558 use 5.006001;
  51         206  
4 51     51   303 use strict;
  51         117  
  51         1305  
5 51     51   282 use warnings;
  51         100  
  51         2039  
6              
7 51     51   316 use Carp qw< carp croak >;
  51         126  
  51         3475  
8 51     51   39969 use Math::BigInt::Lib;
  51         142  
  51         248  
9              
10             our $VERSION = '1.999840';
11             $VERSION =~ tr/_//d;
12              
13             our @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              
29             my $MAX_EXP_F; # the maximum possible base 10 exponent with "no integer"
30             my $MAX_EXP_I; # the maximum possible base 10 exponent with "use integer"
31              
32             my $MAX_BITS; # the maximum possible number of bits for $AND_BITS etc.
33              
34             my $BASE_LEN; # the current base exponent in use
35             my $USE_INT; # whether "use integer" is used in the computations
36              
37             my $BASE; # the current base, e.g., 10000 if $BASE_LEN is 5
38             my $MAX_VAL; # maximum value for an element, i.e., $BASE - 1
39              
40             my $AND_BITS; # maximum value used in binary and, e.g., 0xffff
41             my $OR_BITS; # ditto for binary or
42             my $XOR_BITS; # ditto for binary xor
43              
44             my $AND_MASK; # $AND_BITS + 1, e.g., 0x10000 if $AND_BITS is 0xffff
45             my $OR_MASK; # ditto for binary or
46             my $XOR_MASK; # ditto for binary xor
47              
48             sub config {
49 0     0 0 0 my $self = shift;
50              
51 0 0       0 croak "Missing input argument" unless @_;
52              
53             # Called as a getter.
54              
55 0 0       0 if (@_ == 1) {
56 0         0 my $param = shift;
57 0 0 0     0 croak "Parameter name must be a non-empty string"
58             unless defined $param && length $param;
59 0 0       0 return $BASE_LEN if $param eq 'base_len';
60 0 0       0 return $USE_INT if $param eq 'use_int';
61 0         0 croak "Unknown parameter '$param'";
62             }
63              
64             # Called as a setter.
65              
66 0         0 my $opts;
67 0         0 while (@_) {
68 0         0 my $param = shift;
69 0 0 0     0 croak "Parameter name must be a non-empty string"
70             unless defined $param && length $param;
71 0 0       0 croak "Missing value for parameter '$param'"
72             unless @_;
73 0         0 my $value = shift;
74              
75 0 0 0     0 if ($param eq 'base_len' || $param eq 'use_int') {
76 0         0 $opts -> {$param} = $value;
77 0         0 next;
78             }
79              
80 0         0 croak "Unknown parameter '$param'";
81             }
82              
83 0 0       0 $BASE_LEN = $opts -> {base_len} if exists $opts -> {base_len};
84 0 0       0 $USE_INT = $opts -> {use_int} if exists $opts -> {use_int};
85 0         0 __PACKAGE__ -> _base_len($BASE_LEN, $USE_INT);
86              
87 0         0 return $self;
88             }
89              
90             sub _base_len {
91             #my $class = shift; # $class is not used
92 73     73   3270 shift;
93              
94 73 100       282 if (@_) { # if called as setter ...
95 62         205 my ($base_len, $use_int) = @_;
96              
97 62 50 33     767 croak "The base length must be a positive integer"
      33        
98             unless defined($base_len) && $base_len == int($base_len)
99             && $base_len > 0;
100              
101 62 50 66     762 if ( $use_int && ($base_len > $MAX_EXP_I) ||
      66        
      33        
102             !$use_int && ($base_len > $MAX_EXP_F))
103             {
104 0 0       0 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 62         158 $BASE_LEN = $base_len;
111 62         751 $BASE = 0 + ("1" . ("0" x $BASE_LEN));
112 62         151 $MAX_VAL = $BASE - 1;
113 62 100       269 $USE_INT = $use_int ? 1 : 0;
114              
115             {
116 51     51   501 no warnings "redefine";
  51         154  
  51         46409  
  62         466  
117 62 100       232 if ($use_int) {
118 61         301 *_mul = \&_mul_use_int;
119 61         230 *_div = \&_div_use_int;
120             } else {
121 1         3 *_mul = \&_mul_no_int;
122 1         3 *_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 73         163 my $umax = ~0; # largest unsigned integer
133 73 50       235 my $tmp = $umax < $BASE ? $umax : $BASE;
134              
135 73         163 $MAX_BITS = 0;
136 73         262 while ($tmp >>= 1) {
137 2065         3194 $MAX_BITS++;
138             }
139              
140             # Limit to 32 bits for portability. Is this really necessary? XXX
141              
142 73 50       280 $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 73         271 for ($AND_BITS = $MAX_BITS ; $AND_BITS > 0 ; $AND_BITS--) {
148 73         383 my $x = CORE::oct('0b' . '1' x $AND_BITS);
149 73         208 my $y = $x & $x;
150 73         288 my $z = 2 * (2 ** ($AND_BITS - 1)) + 1;
151 73 0 33     380 last unless $AND_BITS < $MAX_BITS && $x == $z && $y == $x;
      33        
152             }
153              
154 73         297 for ($XOR_BITS = $MAX_BITS ; $XOR_BITS > 0 ; $XOR_BITS--) {
155 73         273 my $x = CORE::oct('0b' . '1' x $XOR_BITS);
156 73         154 my $y = $x ^ $x;
157 73         182 my $z = 2 * (2 ** ($XOR_BITS - 1)) + 1;
158 73 0 33     466 last unless $XOR_BITS < $MAX_BITS && $x == $z && $y == $x;
      33        
159             }
160              
161 73         321 for ($OR_BITS = $MAX_BITS ; $OR_BITS > 0 ; $OR_BITS--) {
162 73         234 my $x = CORE::oct('0b' . '1' x $OR_BITS);
163 73         149 my $y = $x | $x;
164 73         208 my $z = 2 * (2 ** ($OR_BITS - 1)) + 1;
165 73 0 33     392 last unless $OR_BITS < $MAX_BITS && $x == $z && $y == $x;
      33        
166             }
167              
168 73         339 $AND_MASK = __PACKAGE__->_new(( 2 ** $AND_BITS ));
169 73         265 $XOR_MASK = __PACKAGE__->_new(( 2 ** $XOR_BITS ));
170 73         238 $OR_MASK = __PACKAGE__->_new(( 2 ** $OR_BITS ));
171              
172 73 100       65753 return $BASE_LEN unless wantarray;
173 6         46 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              
177             sub _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 188716     188716   423455 my ($class, $str) = @_;
183             #unless ($str =~ /^([1-9]\d*|0)\z/) {
184             # croak("Invalid input string '$str'");
185             #}
186              
187 188716         307693 my $input_len = length($str) - 1;
188              
189             # Shortcut for small numbers.
190 188716 100       609295 return bless [ $str ], $class if $input_len < $BASE_LEN;
191              
192 27263         58696 my $format = "a" . (($input_len % $BASE_LEN) + 1);
193 27263 50       63947 $format .= $] < 5.008 ? "a$BASE_LEN" x int($input_len / $BASE_LEN)
194             : "(a$BASE_LEN)*";
195              
196 27263         171085 my $self = [ reverse(map { 0 + $_ } unpack($format, $str)) ];
  294787         554746  
197 27263         117381 return bless $self, $class;
198             }
199              
200             BEGIN {
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 51     51   284 for ($MAX_EXP_F = 1 ; ; $MAX_EXP_F++) { # when $MAX_EXP_F = 5
224 510         746 my $MAX_EXP_FM1 = $MAX_EXP_F - 1; # = 4
225 510         1178 my $bs = "1" . ("0" x $MAX_EXP_F); # = "100000"
226 510         793 my $xs = "9" x $MAX_EXP_F; # = "99999"
227 510         894 my $cs = ("9" x $MAX_EXP_FM1) . "8"; # = "99998"
228 510         881 my $ys = $cs . ("0" x $MAX_EXP_FM1) . "1"; # = "9999800001"
229              
230             # Compute and check the product.
231 510         941 my $yn = $xs * $xs; # = 9999800001
232 510 50       1164 last if $yn != $ys;
233              
234             # Compute and check the remainder.
235 510         1885 my $rn = $yn % $bs; # = 1
236 510 100       1105 last if $rn != 1;
237              
238             # Compute and check the carry. The division here is exact.
239 459         758 my $cn = ($yn - $rn) / $bs; # = 99998
240 459 50       1010 last if $cn != $cs;
241              
242             # Compute and check product plus carry.
243 459         845 my $zs = $cs . ("9" x $MAX_EXP_F); # = "9999899999"
244 459         630 my $zn = $yn + $cn; # = 99998999999
245 459 50       914 last if $zn != $zs;
246 459 50       1032 last if $zn - ($zn - 1) != 1;
247             }
248 51         143 $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 51         127 my $umax = ~0; # largest unsigned integer
259 51         435 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 51         136 my $MAX_EXP_IM1 = $MAX_EXP_I - 1; # = 4
264 51         186 my $bs = "1" . ("0" x $MAX_EXP_I); # = "100000"
265 51         563 my $xs = "9" x $MAX_EXP_I; # = "99999"
266 51         215 my $cs = ("9" x $MAX_EXP_IM1) . "8"; # = "99998"
267 51         141 my $ys = $cs . ("0" x $MAX_EXP_IM1) . "1"; # = "9999800001"
268              
269             # Compute and check the product.
270 51         139 my $yn = $xs * $xs; # = 9999800001
271 51 50       275 next if $yn != $ys;
272              
273             # Compute and check the remainder.
274 51         140 my $rn = $yn % $bs; # = 1
275 51 50       295 next if $rn != 1;
276              
277             # Compute and check the carry. The division here is exact.
278 51         132 my $cn = ($yn - $rn) / $bs; # = 99998
279 51 50       264 next if $cn != $cs;
280              
281             # Compute and check product plus carry.
282 51         181 my $zs = $cs . ("9" x $MAX_EXP_I); # = "9999899999"
283 51         126 my $zn = $yn + $cn; # = 99998999999
284 51 50       231 next if $zn != $zs;
285 51 50       295 next if $zn - ($zn - 1) != 1;
286 51         168 last;
287             }
288              
289 51 50       273 ($BASE_LEN, $USE_INT) = $MAX_EXP_F > $MAX_EXP_I
290             ? ($MAX_EXP_F, 0) : ($MAX_EXP_I, 1);
291              
292 51         437 __PACKAGE__ -> _base_len($BASE_LEN, $USE_INT);
293             }
294              
295             ###############################################################################
296              
297             sub _zero {
298             # create a zero
299 45806     45806   70857 my $class = shift;
300 45806         139171 return bless [ 0 ], $class;
301             }
302              
303             sub _one {
304             # create a one
305 5064     5064   8279 my $class = shift;
306 5064         13286 return bless [ 1 ], $class;
307             }
308              
309             sub _two {
310             # create a two
311 2316     2316   3642 my $class = shift;
312 2316         6378 return bless [ 2 ], $class;
313             }
314              
315             sub _ten {
316             # create a 10
317 29997     29997   47435 my $class = shift;
318 29997 50       65148 my $self = $BASE_LEN == 1 ? [ 0, 1 ] : [ 10 ];
319 29997         79379 bless $self, $class;
320             }
321              
322             sub _1ex {
323             # create a 1Ex
324 5     5   11 my $class = shift;
325              
326 5         13 my $rem = $_[0] % $BASE_LEN; # remainder
327 5         11 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 5         34 bless [ (0) x $div, 0 + ("1" . ("0" x $rem)) ], $class;
332             }
333              
334             sub _copy {
335             # make a true copy
336 104514     104514   158555 my $class = shift;
337 104514         137364 return bless [ @{ $_[0] } ], $class;
  104514         306295  
338             }
339              
340             sub import {
341 11     11   320 my $self = shift;
342              
343 11         21 my $opts;
344 11         33 my ($base_len, $use_int);
345 11         48 while (@_) {
346 2         4 my $param = shift;
347 2 50 33     10 croak "Parameter name must be a non-empty string"
348             unless defined $param && length $param;
349 2 50       6 croak "Missing value for parameter '$param'"
350             unless @_;
351 2         2 my $value = shift;
352              
353 2 50 66     9 if ($param eq 'base_len' || $param eq 'use_int') {
354 2         5 $opts -> {$param} = $value;
355 2         5 next;
356             }
357              
358 0         0 croak "Unknown parameter '$param'";
359             }
360              
361 11 100       53 $base_len = exists $opts -> {base_len} ? $opts -> {base_len} : $BASE_LEN;
362 11 100       35 $use_int = exists $opts -> {use_int} ? $opts -> {use_int} : $USE_INT;
363 11         53 __PACKAGE__ -> _base_len($base_len, $use_int);
364              
365 11         9542 return $self;
366             }
367              
368             ##############################################################################
369             # convert back to string and number
370              
371             sub _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 61653     61653   100443 my $ary = $_[1];
376 61653         100203 my $idx = $#$ary; # index of last element
377              
378 61653 50       121416 if ($idx < 0) { # should not happen
379 0         0 croak("$_[1] has no elements");
380             }
381              
382             # Handle first one differently, since it should not have any leading zeros.
383 61653         109063 my $ret = int($ary->[$idx]);
384 61653 100       121361 if ($idx > 0) {
385             # Interestingly, the pre-padd method uses more time.
386             # The old grep variant takes longer (14 vs. 10 sec).
387 27512         60944 my $z = '0' x ($BASE_LEN - 1);
388 27512         58430 while (--$idx >= 0) {
389 269260         590219 $ret .= substr($z . $ary->[$idx], -$BASE_LEN);
390             }
391             }
392 61653         147120 $ret;
393             }
394              
395             sub _num {
396             # Make a Perl scalar number (int/float) from a BigInt object.
397 74823     74823   112730 my $x = $_[1];
398              
399 74823 100       209970 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 16         34 my $num = 0;
407 16         77 for (my $i = $#$x ; $i >= 0 ; --$i) {
408 41         68 $num *= $BASE;
409 41         89 $num += $x -> [$i];
410             }
411 16         42 return $num;
412             }
413              
414             ##############################################################################
415             # actual math code
416              
417             sub _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 55282     55282   99362 my ($c, $x, $y) = @_;
425              
426             # $x + 0 => $x
427              
428 55282 100 100     189223 return $x if @$y == 1 && $y->[0] == 0;
429              
430             # 0 + $y => $y->copy
431              
432 48411 100 100     142723 if (@$x == 1 && $x->[0] == 0) {
433 7339         17896 @$x = @$y;
434 7339         17336 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 41072         56259 my $car = 0;
442 41072         54126 my $j = 0;
443 41072         72120 for my $i (@$y) {
444 78840 100       177186 $x->[$j] -= $BASE if $car = (($x->[$j] += $i + $car) >= $BASE) ? 1 : 0;
    100          
445 78840         114076 $j++;
446             }
447 41072         79360 while ($car != 0) {
448 344 100       1877 $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0;
    100          
449 344         788 $j++;
450             }
451 41072         90824 $x;
452             }
453              
454             sub _inc {
455             # (ref to int_num_array, ref to int_num_array)
456             # Add 1 to $x, modify $x in place
457 4592     4592   8733 my ($c, $x) = @_;
458              
459 4592         8423 for my $i (@$x) {
460 4605 100       14849 return $x if ($i += 1) < $BASE; # early out
461 18         47 $i = 0; # overflow, next
462             }
463 5 50       44 push @$x, 1 if $x->[-1] == 0; # last overflowed, so extend
464 5         15 $x;
465             }
466              
467             sub _dec {
468             # (ref to int_num_array, ref to int_num_array)
469             # Sub 1 from $x, modify $x in place
470 831     831   1929 my ($c, $x) = @_;
471              
472 831         1436 my $MAX = $BASE - 1; # since MAX_VAL based on BASE
473 831         1687 for my $i (@$x) {
474 847 100       2203 last if ($i -= 1) >= 0; # early out
475 16         20 $i = $MAX; # underflow, next
476             }
477 831 100 100     2398 pop @$x if $x->[-1] == 0 && @$x > 1; # last underflowed (but leave 0)
478 831         1668 $x;
479             }
480              
481             sub _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 55071     55071   108711 my ($c, $sx, $sy, $s) = @_;
487              
488 55071         79665 my $car = 0;
489 55071         73436 my $j = 0;
490 55071 100       107700 if (!$s) {
491 48976         90700 for my $i (@$sx) {
492 68960 100 100     154214 last unless defined $sy->[$j] || $car;
493 67388 100 100     191572 $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0);
494 67388         106447 $j++;
495             }
496             # might leave leading zeros, so fix that
497 48976         96407 return __strip_zeros($sx);
498             }
499 6095         11623 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 6173 100 100     24780 $sy->[$j] += $BASE
504             if $car = ($sy->[$j] = $i - ($sy->[$j] || 0) - $car) < 0;
505 6173         10845 $j++;
506             }
507             # might leave leading zeros, so fix that
508 6095         11496 __strip_zeros($sy);
509             }
510              
511             sub _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 54307     54307   106896 my ($c, $xv, $yv) = @_;
517 51     51   30409 use integer;
  51         889  
  51         360  
518              
519 54307 100       117981 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 42438 100       78393 if (@$xv == 1) {
523 32107 100       72821 if (($xv->[0] *= $yv->[0]) >= $BASE) {
524 1419         4897 $xv->[0] =
525             $xv->[0] - ($xv->[1] = $xv->[0] / $BASE) * $BASE;
526             }
527 32107         70380 return $xv;
528             }
529             # $x * 0 => 0
530 10331 100       22887 if ($yv->[0] == 0) {
531 15         86 @$xv = (0);
532 15         62 return $xv;
533             }
534              
535             # multiply a large number a by a single element one, so speed up
536 10316         16596 my $y = $yv->[0];
537 10316         14642 my $car = 0;
538 10316         19094 foreach my $i (@$xv) {
539             #$i = $i * $y + $car; $car = $i / $BASE; $i -= $car * $BASE;
540 57807         76053 $i = $i * $y + $car;
541 57807         86056 $i -= ($car = $i / $BASE) * $BASE;
542             }
543 10316 100       21812 push @$xv, $car if $car != 0;
544 10316         26832 return $xv;
545             }
546              
547             # shortcut for result $x == 0 => result = 0
548 11869 100 100     29705 return $xv if @$xv == 1 && $xv->[0] == 0;
549              
550             # since multiplying $x with $x fails, make copy in this case
551 11598 100       32857 $yv = $c->_copy($xv) if $xv == $yv; # same references?
552              
553 11598         21730 my @prod = ();
554 11598         17527 my ($prod, $car, $cty);
555 11598         20803 for my $xi (@$xv) {
556 89906         112052 $car = 0;
557 89906         107057 $cty = 0;
558             # looping through this if $xi == 0 is silly - so optimize it away!
559 89906 100 100     149358 $xi = (shift(@prod) || 0), next if $xi == 0;
560 88209         123881 for my $yi (@$yv) {
561 1218782   100     1982200 $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
562 1218782         1742136 $prod[$cty++] = $prod - ($car = $prod / $BASE) * $BASE;
563             }
564 88209 100       148360 $prod[$cty] += $car if $car; # need really to check for 0?
565 88209   100     162979 $xi = shift(@prod) || 0; # || 0 makes v5.005_3 happy
566             }
567 11598         26010 push @$xv, @prod;
568 11598         31005 $xv;
569             }
570              
571             sub _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 0     0   0 my ($c, $xv, $yv) = @_;
576              
577 0 0       0 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 0 0       0 if (@$xv == 1) {
581 0 0       0 if (($xv->[0] *= $yv->[0]) >= $BASE) {
582 0         0 my $rem = $xv->[0] % $BASE;
583 0         0 $xv->[1] = ($xv->[0] - $rem) / $BASE;
584 0         0 $xv->[0] = $rem;
585             }
586 0         0 return $xv;
587             }
588             # $x * 0 => 0
589 0 0       0 if ($yv->[0] == 0) {
590 0         0 @$xv = (0);
591 0         0 return $xv;
592             }
593              
594             # multiply a large number a by a single element one, so speed up
595 0         0 my $y = $yv->[0];
596 0         0 my $car = 0;
597 0         0 my $rem;
598 0         0 foreach my $i (@$xv) {
599 0         0 $i = $i * $y + $car;
600 0         0 $rem = $i % $BASE;
601 0         0 $car = ($i - $rem) / $BASE;
602 0         0 $i = $rem;
603             }
604 0 0       0 push @$xv, $car if $car != 0;
605 0         0 return $xv;
606             }
607              
608             # shortcut for result $x == 0 => result = 0
609 0 0 0     0 return $xv if @$xv == 1 && $xv->[0] == 0;
610              
611             # since multiplying $x with $x fails, make copy in this case
612 0 0       0 $yv = $c->_copy($xv) if $xv == $yv; # same references?
613              
614 0         0 my @prod = ();
615 0         0 my ($prod, $rem, $car, $cty);
616 0         0 for my $xi (@$xv) {
617 0         0 $car = 0;
618 0         0 $cty = 0;
619             # looping through this if $xi == 0 is silly - so optimize it away!
620 0 0 0     0 $xi = (shift(@prod) || 0), next if $xi == 0;
621 0         0 for my $yi (@$yv) {
622 0   0     0 $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
623 0         0 $rem = $prod % $BASE;
624 0         0 $car = ($prod - $rem) / $BASE;
625 0         0 $prod[$cty++] = $rem;
626             }
627 0 0       0 $prod[$cty] += $car if $car; # need really to check for 0?
628 0   0     0 $xi = shift(@prod) || 0; # || 0 makes v5.005_3 happy
629             }
630 0         0 push @$xv, @prod;
631 0         0 $xv;
632             }
633              
634             sub _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 51     51   32210 use integer;
  51         174  
  51         271  
640              
641 15346     15346   30692 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 15346 100 100     42721 if (@$x == 1 && @$yorg == 1) {
648             # shortcut, $yorg and $x are two small numbers
649 2917 100       5689 if (wantarray) {
650 2612         6087 my $rem = [ $x->[0] % $yorg->[0] ];
651 2612         4494 bless $rem, $c;
652 2612         4873 $x->[0] = $x->[0] / $yorg->[0];
653 2612         7600 return ($x, $rem);
654             } else {
655 305         662 $x->[0] = $x->[0] / $yorg->[0];
656 305         688 return $x;
657             }
658             }
659              
660             # if x has more than one, but y has only one element:
661 12429 100       26159 if (@$yorg == 1) {
662 3443         5035 my $rem;
663 3443 100       7300 $rem = $c->_mod($c->_copy($x), $yorg) if wantarray;
664              
665             # shortcut, $y is < $BASE
666 3443         5039 my $j = @$x;
667 3443         4656 my $r = 0;
668 3443         5895 my $y = $yorg->[0];
669 3443         4661 my $b;
670 3443         7295 while ($j-- > 0) {
671 108960         137026 $b = $r * $BASE + $x->[$j];
672 108960         130853 $r = $b % $y;
673 108960         180425 $x->[$j] = $b / $y;
674             }
675 3443 100 66     13978 pop(@$x) if @$x > 1 && $x->[-1] == 0; # remove any trailing zero
676 3443 100       7429 return ($x, $rem) if wantarray;
677 3096         8364 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 8986 100       19210 if (@$yorg > @$x) {
684 256         339 my $rem;
685 256 100       758 $rem = $c->_copy($x) if wantarray; # make copy
686 256         547 @$x = 0; # set to 0
687 256 100       1094 return ($x, $rem) if wantarray; # including remainder?
688 7         36 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 8730 100       17923 if (@$yorg == @$x) {
694 760         1529 my $cmp = 0;
695 760         2206 for (my $j = $#$x ; $j >= 0 ; --$j) {
696 886 100       2297 last if $cmp = $x->[$j] - $yorg->[$j];
697             }
698              
699 760 100       1600 if ($cmp == 0) { # x = y
700 20         84 @$x = 1;
701 20 100       88 return $x, $c->_zero() if wantarray;
702 8         39 return $x;
703             }
704              
705 740 100       1676 if ($cmp < 0) { # x < y
706 437 100       1028 if (wantarray) {
707 13         52 my $rem = $c->_copy($x);
708 13         54 @$x = 0;
709 13         52 return $x, $rem;
710             }
711 424         985 @$x = 0;
712 424         863 return $x;
713             }
714             }
715              
716             # all other cases:
717              
718 8273         17222 my $y = $c->_copy($yorg); # always make copy to preserve
719              
720 8273         12544 my $tmp;
721 8273         15339 my $dd = $BASE / ($y->[-1] + 1);
722 8273 100       15681 if ($dd != 1) {
723 8078         11504 my $car = 0;
724 8078         15228 for my $xi (@$x) {
725 96505         119956 $xi = $xi * $dd + $car;
726 96505         134049 $xi -= ($car = $xi / $BASE) * $BASE;
727             }
728 8078         14973 push(@$x, $car);
729 8078         11610 $car = 0;
730 8078         13140 for my $yi (@$y) {
731 44527         56268 $yi = $yi * $dd + $car;
732 44527         63581 $yi -= ($car = $yi / $BASE) * $BASE;
733             }
734             } else {
735 195         697 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 8273         13902 my @q = ();
742 8273         18084 my ($v2, $v1) = @$y[-2, -1];
743 8273 100       16846 $v2 = 0 unless $v2;
744 8273         19107 while ($#$x > $#$y) {
745 61790         113525 my ($u2, $u1, $u0) = @$x[-3 .. -1];
746 61790 100       104083 $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 61790         84594 my $tmp = $u0 * $BASE + $u1;
750 61790         80640 my $rem = $tmp % $v1;
751 61790 100       104321 my $q = $u0 == $v1 ? $MAX_VAL : (($tmp - $rem) / $v1);
752 61790         129503 --$q while $v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2;
753 61790 100       101554 if ($q) {
754 57110         69217 my $prd;
755 57110         82106 my ($car, $bar) = (0, 0);
756 57110         125532 for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) {
757 485360         619112 $prd = $q * $y->[$yi] + $car;
758 485360         618299 $prd -= ($car = int($prd / $BASE)) * $BASE;
759 485360 100       1141219 $x->[$xi] += $BASE if $bar = (($x->[$xi] -= $prd + $bar) < 0);
760             }
761 57110 100       111188 if ($x->[-1] < $car + $bar) {
762 17         61 $car = 0;
763 17         31 --$q;
764 17         83 for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) {
765 91 100       257 $x->[$xi] -= $BASE
766             if $car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE);
767             }
768             }
769             }
770 61790         81390 pop(@$x);
771 61790         139489 unshift(@q, $q);
772             }
773              
774 8273 100       16345 if (wantarray) {
775 1251         2137 my $d = bless [], $c;
776 1251 100       2369 if ($dd != 1) {
777 1237         1641 my $car = 0;
778 1237         1556 my $prd;
779 1237         2033 for my $xi (reverse @$x) {
780 4542         5831 $prd = $car * $BASE + $xi;
781 4542         5849 $car = $prd - ($tmp = $prd / $dd) * $dd;
782 4542         7028 unshift @$d, $tmp;
783             }
784             } else {
785 14         55 @$d = @$x;
786             }
787 1251         2847 @$x = @q;
788 1251         3084 __strip_zeros($x);
789 1251         2568 __strip_zeros($d);
790 1251         4433 return ($x, $d);
791             }
792 7022         20435 @$x = @q;
793 7022         18830 __strip_zeros($x);
794 7022         26476 $x;
795             }
796              
797             sub _div_no_int {
798             # ref to array, ref to array, modify first array and return remainder if
799             # in list context
800              
801 0     0   0 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 0 0 0     0 if (@$x == 1 && @$yorg == 1) {
808             # shortcut, $yorg and $x are two small numbers
809 0         0 my $rem = [ $x->[0] % $yorg->[0] ];
810 0         0 bless $rem, $c;
811 0         0 $x->[0] = ($x->[0] - $rem->[0]) / $yorg->[0];
812 0 0       0 return ($x, $rem) if wantarray;
813 0         0 return $x;
814             }
815              
816             # if x has more than one, but y has only one element:
817 0 0       0 if (@$yorg == 1) {
818 0         0 my $rem;
819 0 0       0 $rem = $c->_mod($c->_copy($x), $yorg) if wantarray;
820              
821             # shortcut, $y is < $BASE
822 0         0 my $j = @$x;
823 0         0 my $r = 0;
824 0         0 my $y = $yorg->[0];
825 0         0 my $b;
826 0         0 while ($j-- > 0) {
827 0         0 $b = $r * $BASE + $x->[$j];
828 0         0 $r = $b % $y;
829 0         0 $x->[$j] = ($b - $r) / $y;
830             }
831 0 0 0     0 pop(@$x) if @$x > 1 && $x->[-1] == 0; # remove any trailing zero
832 0 0       0 return ($x, $rem) if wantarray;
833 0         0 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 0 0       0 if (@$yorg > @$x) {
840 0         0 my $rem;
841 0 0       0 $rem = $c->_copy($x) if wantarray; # make copy
842 0         0 @$x = 0; # set to 0
843 0 0       0 return ($x, $rem) if wantarray; # including remainder?
844 0         0 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 0 0       0 if (@$yorg == @$x) {
850 0         0 my $cmp = 0;
851 0         0 for (my $j = $#$x ; $j >= 0 ; --$j) {
852 0 0       0 last if $cmp = $x->[$j] - $yorg->[$j];
853             }
854              
855 0 0       0 if ($cmp == 0) { # x = y
856 0         0 @$x = 1;
857 0 0       0 return $x, $c->_zero() if wantarray;
858 0         0 return $x;
859             }
860              
861 0 0       0 if ($cmp < 0) { # x < y
862 0 0       0 if (wantarray) {
863 0         0 my $rem = $c->_copy($x);
864 0         0 @$x = 0;
865 0         0 return $x, $rem;
866             }
867 0         0 @$x = 0;
868 0         0 return $x;
869             }
870             }
871              
872             # all other cases:
873              
874 0         0 my $y = $c->_copy($yorg); # always make copy to preserve
875              
876 0         0 my $tmp = $y->[-1] + 1;
877 0         0 my $rem = $BASE % $tmp;
878 0         0 my $dd = ($BASE - $rem) / $tmp;
879 0 0       0 if ($dd != 1) {
880 0         0 my $car = 0;
881 0         0 for my $xi (@$x) {
882 0         0 $xi = $xi * $dd + $car;
883 0         0 $rem = $xi % $BASE;
884 0         0 $car = ($xi - $rem) / $BASE;
885 0         0 $xi = $rem;
886             }
887 0         0 push(@$x, $car);
888 0         0 $car = 0;
889 0         0 for my $yi (@$y) {
890 0         0 $yi = $yi * $dd + $car;
891 0         0 $rem = $yi % $BASE;
892 0         0 $car = ($yi - $rem) / $BASE;
893 0         0 $yi = $rem;
894             }
895             } else {
896 0         0 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 0         0 my @q = ();
903 0         0 my ($v2, $v1) = @$y[-2, -1];
904 0 0       0 $v2 = 0 unless $v2;
905 0         0 while ($#$x > $#$y) {
906 0         0 my ($u2, $u1, $u0) = @$x[-3 .. -1];
907 0 0       0 $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 0         0 my $tmp = $u0 * $BASE + $u1;
911 0         0 my $rem = $tmp % $v1;
912 0 0       0 my $q = $u0 == $v1 ? $MAX_VAL : (($tmp - $rem) / $v1);
913 0         0 --$q while $v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2;
914 0 0       0 if ($q) {
915 0         0 my $prd;
916 0         0 my ($car, $bar) = (0, 0);
917 0         0 for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) {
918 0         0 $prd = $q * $y->[$yi] + $car;
919 0         0 $rem = $prd % $BASE;
920 0         0 $car = ($prd - $rem) / $BASE;
921 0         0 $prd -= $car * $BASE;
922 0 0       0 $x->[$xi] += $BASE if $bar = (($x->[$xi] -= $prd + $bar) < 0);
923             }
924 0 0       0 if ($x->[-1] < $car + $bar) {
925 0         0 $car = 0;
926 0         0 --$q;
927 0         0 for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) {
928 0 0       0 $x->[$xi] -= $BASE
929             if $car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE);
930             }
931             }
932             }
933 0         0 pop(@$x);
934 0         0 unshift(@q, $q);
935             }
936              
937 0 0       0 if (wantarray) {
938 0         0 my $d = bless [], $c;
939 0 0       0 if ($dd != 1) {
940 0         0 my $car = 0;
941 0         0 my ($prd, $rem);
942 0         0 for my $xi (reverse @$x) {
943 0         0 $prd = $car * $BASE + $xi;
944 0         0 $rem = $prd % $dd;
945 0         0 $tmp = ($prd - $rem) / $dd;
946 0         0 $car = $rem;
947 0         0 unshift @$d, $tmp;
948             }
949             } else {
950 0         0 @$d = @$x;
951             }
952 0         0 @$x = @q;
953 0         0 __strip_zeros($x);
954 0         0 __strip_zeros($d);
955 0         0 return ($x, $d);
956             }
957 0         0 @$x = @q;
958 0         0 __strip_zeros($x);
959 0         0 $x;
960             }
961              
962             ##############################################################################
963             # testing
964              
965             sub _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 110668     110668   202732 my ($c, $cx, $cy) = @_;
970              
971             # shortcut for short numbers
972 110668 100 100     455344 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 18519   100     60563 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 18519 100       43531 return -1 if $lxy < 0; # already differs, ret
983 15615 100       36953 return 1 if $lxy > 0; # ditto
984              
985             # manual way (abort if unequal, good for early ne)
986 11536         14903 my $a;
987 11536         16450 my $j = @$cx;
988 11536         21637 while (--$j >= 0) {
989 37834 100       78802 last if $a = $cx->[$j] - $cy->[$j];
990             }
991 11536         42961 $a <=> 0;
992             }
993              
994             sub _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 103112     103112   161196 my $cx = $_[1];
1000              
1001 103112         312656 (@$cx - 1) * $BASE_LEN + length(int($cx->[-1]));
1002             }
1003              
1004             sub _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 97     97   227 my ($c, $x, $n) = @_;
1008              
1009 97         226 my $len = _len('', $x);
1010              
1011 97 100       274 $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 97 100 100     386 return "0" if $n < 0 || $n >= $len; # return 0 for digits out of range
1017              
1018 95         221 my $elem = int($n / $BASE_LEN); # index of array element
1019 95         171 my $digit = $n % $BASE_LEN; # index of digit within the element
1020 95         1141 substr("0" x $BASE_LEN . "$x->[$elem]", -1 - $digit, 1);
1021             }
1022              
1023             sub _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 78937     78937   2256978 my $x = $_[1];
1029              
1030 78937 100 100     235600 return 0 if @$x == 1 && $x->[0] == 0;
1031              
1032 76485         117683 my $zeros = 0;
1033 76485         142090 foreach my $elem (@$x) {
1034 222025 100       372448 if ($elem != 0) {
1035 76485         344745 $elem =~ /[^0](0*)\z/;
1036 76485         186574 $zeros += length($1); # count trailing zeros
1037 76485         127881 last; # early out
1038             }
1039 145540         193443 $zeros += $BASE_LEN;
1040             }
1041 76485         163843 $zeros;
1042             }
1043              
1044             ##############################################################################
1045             # _is_* routines
1046              
1047             sub _is_zero {
1048             # return true if arg is zero
1049 384382 100 100 384382   521728 @{$_[1]} == 1 && $_[1]->[0] == 0 ? 1 : 0;
1050             }
1051              
1052             sub _is_even {
1053             # return true if arg is even
1054 86 100   86   1074 $_[1]->[0] % 2 ? 0 : 1;
1055             }
1056              
1057             sub _is_odd {
1058             # return true if arg is odd
1059 706 100   706   3861 $_[1]->[0] % 2 ? 1 : 0;
1060             }
1061              
1062             sub _is_one {
1063             # return true if arg is one
1064 6213 100 100 6213   9762 @{$_[1]} == 1 && $_[1]->[0] == 1 ? 1 : 0;
1065             }
1066              
1067             sub _is_two {
1068             # return true if arg is two
1069 154 100 100 154   1124 @{$_[1]} == 1 && $_[1]->[0] == 2 ? 1 : 0;
1070             }
1071              
1072             sub _is_ten {
1073             # return true if arg is ten
1074 2 50   2   8 if ($BASE_LEN == 1) {
1075 0 0 0     0 @{$_[1]} == 2 && $_[1]->[0] == 0 && $_[1]->[1] == 1 ? 1 : 0;
1076             } else {
1077 2 100 66     4 @{$_[1]} == 1 && $_[1]->[0] == 10 ? 1 : 0;
1078             }
1079             }
1080              
1081             sub __strip_zeros {
1082             # Internal normalization function that strips leading zeros from the array.
1083             # Args: ref to array
1084 64604     64604   110200 my $x = shift;
1085              
1086 64604 100       127562 push @$x, 0 if @$x == 0; # div might return empty results, so fix it
1087 64604 100       183628 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 13071         20535 my $i = $#$x;
1099 13071         26869 while ($i > 0) {
1100 21979 100       41884 last if $x->[$i] != 0;
1101 9395         16596 $i--;
1102             }
1103 13071         17341 $i++;
1104 13071 100       27308 splice(@$x, $i) if $i < @$x;
1105 13071         24435 $x;
1106             }
1107              
1108             ###############################################################################
1109             # check routine to test internal state for corruptions
1110              
1111             sub _check {
1112             # used by the test suite
1113 5498     5498   2022358 my ($class, $x) = @_;
1114              
1115 5498         20423 my $msg = $class -> SUPER::_check($x);
1116 5498 100       12376 return $msg if $msg;
1117              
1118 5497         8280 my $n;
1119 5497         8315 eval { $n = @$x };
  5497         9485  
1120 5497 50       11372 return "Not an array reference" unless $@ eq '';
1121              
1122 5497 50       11562 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 5497         14895 for (my $i = 0 ; $i <= $#$x ; ++ $i) {
1130 6292         11559 my $e = $x -> [$i];
1131              
1132 6292 50       11321 return "Element at index $i is undefined"
1133             unless defined $e;
1134              
1135 6292 50       12596 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 6292 50       22338 return "Element at index $i is '$e', which does not look like an" .
1143             " normal integer" unless $e =~ /^\d+\z/;
1144              
1145 6292 50       14097 return "Element at index $i is '$e', which is not smaller than" .
1146             " the base '$BASE'" if $e >= $BASE;
1147              
1148 6292 50 100     26102 return "Element at index $i (last element) is zero"
      66        
1149             if $#$x > 0 && $i == $#$x && $e == 0;
1150             }
1151              
1152 5497         13471 return 0;
1153             }
1154              
1155             ###############################################################################
1156              
1157             sub _mod {
1158             # if possible, use mod shortcut
1159 2989     2989   5488 my ($c, $x, $yo) = @_;
1160              
1161             # slow way since $y too big
1162 2989 100       6728 if (@$yo > 1) {
1163 805         1721 my ($xo, $rem) = $c->_div($x, $yo);
1164 805         1599 @$x = @$rem;
1165 805         2011 return $x;
1166             }
1167              
1168 2184         3620 my $y = $yo->[0];
1169              
1170             # if both are single element arrays
1171 2184 100       4309 if (@$x == 1) {
1172 1654         2726 $x->[0] %= $y;
1173 1654         3860 return $x;
1174             }
1175              
1176             # if @$x has more than one element, but @$y is a single element
1177 530         1063 my $b = $BASE % $y;
1178 530 100       1415 if ($b == 0) {
    100          
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 15         32 $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 155         251 my $r = 0;
1187 155         327 foreach (@$x) {
1188 310         580 $r = ($r + $_) % $y; # not much faster, but heh...
1189             #$r += $_ % $y; $r %= $y;
1190             }
1191 155 50       320 $r = 0 if $r == $y;
1192 155         282 $x->[0] = $r;
1193             } else {
1194             # else need to go through all elements in @$x: O(N)
1195 360         590 my $r = 0;
1196 360         570 my $bm = 1;
1197 360         708 foreach (@$x) {
1198 2561         3421 $r = ($_ * $bm + $r) % $y;
1199 2561         3738 $bm = ($bm * $b) % $y;
1200              
1201             #$r += ($_ % $y) * $bm;
1202             #$bm *= $b;
1203             #$bm %= $y;
1204             #$r %= $y;
1205             }
1206 360 50       799 $r = 0 if $r == $y;
1207 360         675 $x->[0] = $r;
1208             }
1209 530         1204 @$x = $x->[0]; # keep one element of @$x
1210 530         1068 return $x;
1211             }
1212              
1213             ##############################################################################
1214             # shifts
1215              
1216             sub _rsft {
1217 29993     29993   59625 my ($c, $x, $n, $b) = @_;
1218 29993 50 33     64267 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 29993 50       80803 $b = $c->_new($b) unless ref $b;
1223              
1224 29993 100       67038 if ($c -> _acmp($b, $c -> _ten())) {
1225 49         186 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 29944         61674 my $dst = 0; # destination
1231 29944         66249 my $src = $c->_num($n); # as normal int
1232 29944         71506 my $xlen = (@$x - 1) * $BASE_LEN + length(int($x->[-1]));
1233 29944 100 33     97005 if ($src >= $xlen or ($src == $xlen and !defined $x->[1])) {
      66        
1234             # 12345 67890 shifted right by more than 10 digits => 0
1235 165         468 splice(@$x, 1); # leave only one element
1236 165         323 $x->[0] = 0; # set to zero
1237 165         581 return $x;
1238             }
1239 29779         50154 my $rem = $src % $BASE_LEN; # remainder to shift
1240 29779         62685 $src = int($src / $BASE_LEN); # source
1241 29779 100       53671 if ($rem == 0) {
1242 1701         4039 splice(@$x, 0, $src); # even faster, 38.4 => 39.3
1243             } else {
1244 28078         43605 my $len = @$x - $src; # elems to go
1245 28078         37347 my $vd;
1246 28078         53457 my $z = '0' x $BASE_LEN;
1247 28078         65585 $x->[ @$x ] = 0; # avoid || 0 test inside loop
1248 28078         56223 while ($dst < $len) {
1249 180903         253524 $vd = $z . $x->[$src];
1250 180903         277428 $vd = substr($vd, -$BASE_LEN, $BASE_LEN - $rem);
1251 180903         221210 $src++;
1252 180903         345603 $vd = substr($z . $x->[$src], -$rem, $rem) . $vd;
1253 180903 50       332573 $vd = substr($vd, -$BASE_LEN, $BASE_LEN) if length($vd) > $BASE_LEN;
1254 180903         276969 $x->[$dst] = int($vd);
1255 180903         302662 $dst++;
1256             }
1257 28078 50       69827 splice(@$x, $dst) if $dst > 0; # kill left-over array elems
1258 28078 100 66     92227 pop(@$x) if $x->[-1] == 0 && @$x > 1; # kill last element if 0
1259             } # else rem == 0
1260 29779         91358 $x;
1261             }
1262              
1263             sub _lsft {
1264 23383     23383   50157 my ($c, $x, $n, $b) = @_;
1265              
1266 23383 100 100     48875 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 19451 100       54994 $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 19451         45737 my $bstr = $c->_str($b);
1276 19451 100       87914 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 19423         47203 my $log10b = length($1);
1282 19423         40483 $n = $c->_mul($c->_new($log10b), $n);
1283 19423         43112 $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 19423         45714 my $r = $n % $BASE_LEN;
1290 19423         39098 my $q = ($n - $r) / $BASE_LEN;
1291              
1292             # If we must shift the values within the elements ...
1293              
1294 19423 100       37136 if ($r) {
1295 17766         26368 my $i = @$x; # index
1296 17766         35212 $x->[$i] = 0; # initialize most significant element
1297 17766         35939 my $z = '0' x $BASE_LEN;
1298 17766         24491 my $vd;
1299 17766         36708 while ($i >= 0) {
1300 134602         187459 $vd = $x->[$i];
1301 134602         213017 $vd = $z . $vd;
1302 134602         227827 $vd = substr($vd, $r - $BASE_LEN, $BASE_LEN - $r);
1303 134602 100       292862 $vd .= $i > 0 ? substr($z . $x->[$i - 1], -$BASE_LEN, $r)
1304             : '0' x $r;
1305 134602 50       227814 $vd = substr($vd, -$BASE_LEN, $BASE_LEN) if length($vd) > $BASE_LEN;
1306 134602         211413 $x->[$i] = int($vd); # e.g., "0...048" -> 48 etc.
1307 134602         226218 $i--;
1308             }
1309              
1310 17766 100       40569 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 19423 100       38298 if ($q) {
1316 15563         57926 unshift @$x, (0) x $q;
1317             }
1318              
1319             } else {
1320 28         126 $x = $c->_mul($x, $c->_pow($b, $n));
1321             }
1322              
1323 19451         67094 return $x;
1324             }
1325              
1326             sub _pow {
1327             # power of $x to $y
1328             # ref to array, ref to array, return ref to array
1329 1014     1014   2458 my ($c, $cx, $cy) = @_;
1330              
1331 1014 100 66     4386 if (@$cy == 1 && $cy->[0] == 0) {
1332 64         183 splice(@$cx, 1);
1333 64         155 $cx->[0] = 1; # y == 0 => x => 1
1334 64         174 return $cx;
1335             }
1336              
1337 950 100 100     5722 if ((@$cx == 1 && $cx->[0] == 1) || # x == 1
      66        
      100        
1338             (@$cy == 1 && $cy->[0] == 1)) # or y == 1
1339             {
1340 144         443 return $cx;
1341             }
1342              
1343 806 100 100     2650 if (@$cx == 1 && $cx->[0] == 0) {
1344 1         3 splice (@$cx, 1);
1345 1         4 $cx->[0] = 0; # 0 ** y => 0 (if not y <= 0)
1346 1         4 return $cx;
1347             }
1348              
1349 805         1897 my $pow2 = $c->_one();
1350              
1351 805         2195 my $y_bin = $c->_as_bin($cy);
1352 805         2617 $y_bin =~ s/^0b//;
1353 805         1503 my $len = length($y_bin);
1354 805         1914 while (--$len > 0) {
1355 1869 100       5004 $c->_mul($pow2, $cx) if substr($y_bin, $len, 1) eq '1'; # is odd?
1356 1869         4008 $c->_mul($cx, $cx);
1357             }
1358              
1359 805         2343 $c->_mul($cx, $pow2);
1360 805         2681 $cx;
1361             }
1362              
1363             sub _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 56     56   132 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 56         90 my $twok = $c->_mul($c->_two(), $c->_copy($k)); # 2 * k
  56         153  
1375 56 100       208 if ($c->_acmp($twok, $n) > 0) { # if 2*k > n
1376 28         77 $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 56 100       178 if ($c->_is_zero($k)) {
1387 21         68 @$n = 1;
1388             } else {
1389              
1390             # Make a copy of the original n, since we'll be modifying n in-place.
1391              
1392 35         251 my $n_orig = $c->_copy($n);
1393              
1394             # n = 5, f = 6, d = 2 (cf. example above)
1395              
1396 35         125 $c->_sub($n, $k);
1397 35         167 $c->_inc($n);
1398              
1399 35         73 my $f = $c->_copy($n);
1400 35         115 $c->_inc($f);
1401              
1402 35         89 my $d = $c->_two();
1403              
1404             # while f <= n (the original n, that is) ...
1405              
1406 35         99 while ($c->_acmp($f, $n_orig) <= 0) {
1407              
1408             # n = (n * f / d) == 5 * 6 / 2 (cf. example above)
1409              
1410 105         281 $c->_mul($n, $f);
1411 105         258 $c->_div($n, $d);
1412              
1413             # f = 7, d = 3 (cf. example above)
1414              
1415 105         386 $c->_inc($f);
1416 105         185 $c->_inc($d);
1417             }
1418              
1419             }
1420              
1421 56         600 return $n;
1422             }
1423              
1424             sub _fac {
1425             # factorial of $x
1426             # ref to array, return ref to array
1427 140     140   385 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 140 50       348 if (@$cx == 1) {
1433 140         475 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 140 100       442 if ($cx->[0] <= $#factorials) {
1447 69         187 my $tmp = $c -> _new($factorials[ $cx->[0] ]);
1448 69         200 @$cx = @$tmp;
1449 69         261 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 71 50       423 if ($BASE_LEN <= 2) {
1461 0         0 my $tmp = $c -> SUPER::_fac($cx);
1462 0         0 @$cx = @$tmp;
1463 0         0 return $cx;
1464             }
1465              
1466             # This code does not work for small values of $BASE_LEN.
1467              
1468 71 100 66     456 if ((@$cx == 1) && # we do this only if $x >= 12 and $x <= 7000
      33        
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 55         125 my $zero_elements = 0;
1484              
1485             # If n is even, set n = n -1
1486 55         172 my $k = $c->_num($cx);
1487 55         117 my $even = 1;
1488 55 100       168 if (($k & 1) == 0) {
1489 35         64 $even = $k;
1490 35         72 $k --;
1491             }
1492             # set k to the center point
1493 55         137 $k = ($k + 1) / 2;
1494             # print "k $k even: $even\n";
1495             # now calculate k * k
1496 55         102 my $k2 = $k * $k;
1497 55         88 my $odd = 1;
1498 55         267 my $sum = 1;
1499 55         269 my $i = $k - 1;
1500             # keep reference to x
1501 55         166 my $new_x = $c->_new($k * $even);
1502 55         179 @$cx = @$new_x;
1503 55 50       178 if ($cx->[0] == 0) {
1504 0         0 $zero_elements ++;
1505 0         0 shift @$cx;
1506             }
1507             # print STDERR "x = ", $c->_str($cx), "\n";
1508 55         145 my $BASE2 = int(sqrt($BASE))-1;
1509 55         88 my $j = 1;
1510 55         135 while ($j <= $i) {
1511 282         402 my $m = ($k2 - $sum);
1512 282         389 $odd += 2;
1513 282         383 $sum += $odd;
1514 282         537 $j++;
1515 282   100     1121 while ($j <= $i && ($m < $BASE2) && (($k2 - $sum) < $BASE2)) {
      66        
1516 366         515 $m *= ($k2 - $sum);
1517 366         475 $odd += 2;
1518 366         458 $sum += $odd;
1519 366         1077 $j++;
1520             # print STDERR "\n k2 $k2 m $m sum $sum odd $odd\n"; sleep(1);
1521             }
1522 282 50       489 if ($m < $BASE) {
1523 282         686 $c->_mul($cx, [$m]);
1524             } else {
1525 0         0 $c->_mul($cx, $c->_new($m));
1526             }
1527 282 100       814 if ($cx->[0] == 0) {
1528 10         42 $zero_elements ++;
1529 10         41 shift @$cx;
1530             }
1531             # print STDERR "Calculate $k2 - $sum = $m (x = ", $c->_str($cx), ")\n";
1532             }
1533             # multiply in the zeros again
1534 55         200 unshift @$cx, (0) x $zero_elements;
1535 55         229 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 16         42 my $steps = 100;
1541 16 50       60 $steps = $cx->[0] if @$cx == 1;
1542 16         33 my $r = 2;
1543 16         29 my $cf = 3;
1544 16         27 my $step = 2;
1545 16         31 my $last = $r;
1546 16   66     110 while ($r * $cf < $BASE && $step < $steps) {
1547 136         187 $last = $r;
1548 136         206 $r *= $cf++;
1549 136         596 $step++;
1550             }
1551 16 50 33     145 if ((@$cx == 1) && $step == $cx->[0]) {
1552             # completely done, so keep reference to $x and return
1553 16         41 $cx->[0] = $r;
1554 16         62 return $cx;
1555             }
1556              
1557             # now we must do the left over steps
1558 0         0 my $n; # steps still to do
1559 0 0       0 if (@$cx == 1) {
1560 0         0 $n = $cx->[0];
1561             } else {
1562 0         0 $n = $c->_copy($cx);
1563             }
1564              
1565             # Set $cx to the last result below $BASE (but keep ref to $x)
1566 0         0 $cx->[0] = $last;
1567 0         0 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 0         0 my $zero_elements = 0;
1572              
1573             # do left-over steps fit into a scalar?
1574 0 0       0 if (ref $n eq 'ARRAY') {
1575             # No, so use slower inc() & cmp()
1576             # ($n is at least $BASE here)
1577 0         0 my $base_2 = int(sqrt($BASE)) - 1;
1578             #print STDERR "base_2: $base_2\n";
1579 0         0 while ($step < $base_2) {
1580 0 0       0 if ($cx->[0] == 0) {
1581 0         0 $zero_elements ++;
1582 0         0 shift @$cx;
1583             }
1584 0         0 my $b = $step * ($step + 1);
1585 0         0 $step += 2;
1586 0         0 $c->_mul($cx, [$b]);
1587             }
1588 0         0 $step = [$step];
1589 0         0 while ($c->_acmp($step, $n) <= 0) {
1590 0 0       0 if ($cx->[0] == 0) {
1591 0         0 $zero_elements ++;
1592 0         0 shift @$cx;
1593             }
1594 0         0 $c->_mul($cx, $step);
1595 0         0 $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 0         0 my $base_4 = int(sqrt(sqrt($BASE))) - 2;
1603             #print STDERR "base_4: $base_4\n";
1604 0         0 my $n4 = $n - 4;
1605 0   0     0 while ($step < $n4 && $step < $base_4) {
1606 0 0       0 if ($cx->[0] == 0) {
1607 0         0 $zero_elements ++;
1608 0         0 shift @$cx;
1609             }
1610 0         0 my $b = $step * ($step + 1);
1611 0         0 $step += 2;
1612 0         0 $b *= $step * ($step + 1);
1613 0         0 $step += 2;
1614 0         0 $c->_mul($cx, [$b]);
1615             }
1616 0         0 my $base_2 = int(sqrt($BASE)) - 1;
1617 0         0 my $n2 = $n - 2;
1618             #print STDERR "base_2: $base_2\n";
1619 0   0     0 while ($step < $n2 && $step < $base_2) {
1620 0 0       0 if ($cx->[0] == 0) {
1621 0         0 $zero_elements ++;
1622 0         0 shift @$cx;
1623             }
1624 0         0 my $b = $step * ($step + 1);
1625 0         0 $step += 2;
1626 0         0 $c->_mul($cx, [$b]);
1627             }
1628             # do what's left over
1629 0         0 while ($step <= $n) {
1630 0         0 $c->_mul($cx, [$step]);
1631 0         0 $step++;
1632 0 0       0 if ($cx->[0] == 0) {
1633 0         0 $zero_elements ++;
1634 0         0 shift @$cx;
1635             }
1636             }
1637             }
1638             # multiply in the zeros again
1639 0         0 unshift @$cx, (0) x $zero_elements;
1640 0         0 $cx; # return result
1641             }
1642              
1643             sub _log_int {
1644             # calculate integer log of $x to base $base
1645             # ref to array, ref to array - return ref to array
1646 85     85   180 my ($c, $x, $base) = @_;
1647              
1648             # X == 0 => NaN
1649 85 50 66     338 return if @$x == 1 && $x->[0] == 0;
1650              
1651             # BASE 0 or 1 => NaN
1652 85 50 66     301 return if @$base == 1 && $base->[0] < 2;
1653              
1654             # X == 1 => 0 (is exact)
1655 85 50 66     271 if (@$x == 1 && $x->[0] == 1) {
1656 0         0 @$x = 0;
1657 0         0 return $x, 1;
1658             }
1659              
1660 85         203 my $cmp = $c->_acmp($x, $base);
1661              
1662             # X == BASE => 1 (is exact)
1663 85 50       212 if ($cmp == 0) {
1664 0         0 @$x = 1;
1665 0         0 return $x, 1;
1666             }
1667              
1668             # 1 < X < BASE => 0 (is truncated)
1669 85 100       228 if ($cmp < 0) {
1670 4         26 @$x = 0;
1671 4         18 return $x, 0;
1672             }
1673              
1674 81         228 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 81         212 my $len = $c->_len($x_org);
1679 81         328 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 81         183 $log += (@$base - 1) * $BASE_LEN;
1685              
1686             # calculate now a guess based on the values obtained above:
1687 81         235 my $res = $c->_new(int($len / $log));
1688              
1689 81         267 @$x = @$res;
1690 81         195 my $trial = $c->_pow($c->_copy($base), $x);
1691 81         203 my $acmp = $c->_acmp($trial, $x_org);
1692              
1693             # Did we get the exact result?
1694              
1695 81 100       254 return $x, 1 if $acmp == 0;
1696              
1697             # Too small?
1698              
1699 64         146 while ($acmp < 0) {
1700 7         33 $c->_mul($trial, $base);
1701 7         38 $c->_inc($x);
1702 7         21 $acmp = $c->_acmp($trial, $x_org);
1703             }
1704              
1705             # Too big?
1706              
1707 64         157 while ($acmp > 0) {
1708 81         224 $c->_div($trial, $base);
1709 81         243 $c->_dec($x);
1710 81         168 $acmp = $c->_acmp($trial, $x_org);
1711             }
1712              
1713 64 100       282 return $x, 1 if $acmp == 0; # result is exact
1714 19         80 return $x, 0; # result is too small
1715             }
1716              
1717             # for debugging:
1718 51     51   272824 use constant DEBUG => 0;
  51         136  
  51         81282  
1719             my $steps = 0;
1720 0     0 0 0 sub steps { $steps };
1721              
1722             sub _sqrt {
1723             # square-root of $x in-place
1724              
1725 932     932   1896 my ($c, $x) = @_;
1726              
1727 932 100       2103 if (@$x == 1) {
1728             # fits into one Perl scalar, so result can be computed directly
1729 292         988 $x->[0] = int(sqrt($x->[0]));
1730 292         855 return $x;
1731             }
1732              
1733             # Create an initial guess for the square root.
1734              
1735 640         907 my $s;
1736 640 100       1574 if (@$x % 2) {
1737 225         976 $s = [ (0) x ((@$x - 1) / 2), int(sqrt($x->[-1])) ];
1738             } else {
1739 415         1918 $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 640         1124 my $cmp;
1749 640         1004 while (1) {
1750 1999         4444 my $sq = $c -> _mul($c -> _copy($s), $s);
1751 1999         4688 $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 1999 100       4937 if ($cmp > 0) {
    100          
1760 1352         2923 my $num = $c -> _sub($c -> _copy($sq), $x);
1761 1352         3400 my $den = $c -> _mul($c -> _two(), $s);
1762 1352         3427 my $delta = $c -> _div($num, $den);
1763 1352 100       3196 last if $c -> _is_zero($delta);
1764 934         2151 $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 538         1391 my $num = $c -> _sub($c -> _copy($x), $sq);
1775 538         1642 my $den = $c -> _mul($c -> _two(), $s);
1776 538         1597 my $delta = $c -> _div($num, $den);
1777 538 100       1486 last if $c -> _is_zero($delta);
1778 425         1272 $s = $c -> _add($s, $delta);
1779             }
1780              
1781             # If x(n)*x(n) = y, we have the exact result.
1782              
1783             else {
1784 109         289 last;
1785             }
1786             }
1787              
1788 640 100       2300 $s = $c -> _dec($s) if $cmp > 0; # never overshoot
1789 640         1606 @$x = @$s;
1790 640         1905 return $x;
1791             }
1792              
1793             sub _root {
1794             # Take n'th root of $x in place.
1795              
1796 109     109   432 my ($c, $x, $n) = @_;
1797              
1798             # Small numbers.
1799              
1800 109 100       295 if (@$x == 1) {
1801 68 50 33     335 return $x if $x -> [0] == 0 || $x -> [0] == 1;
1802              
1803 68 50       208 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 68         400 my $y = int($x->[0] ** (1 / $n->[0]));
1807 68         120 my $yp1 = $y + 1;
1808 68 100       201 $y = $yp1 if $yp1 ** $n->[0] == $x->[0];
1809 68         145 $x->[0] = $y;
1810 68         213 return $x;
1811             }
1812             }
1813              
1814             # If x <= n, the result is always (truncated to) 1.
1815              
1816 41 50 33     244 if ((@$x > 1 || $x -> [0] > 0) && # if x is non-zero ...
      33        
1817             $c -> _acmp($x, $n) <= 0) # ... and x <= n
1818             {
1819 0         0 my $one = $c -> _one();
1820 0         0 @$x = @$one;
1821 0         0 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 41         137 my $b = $c -> _as_bin($n);
1828 41 100       245 if ($b =~ /0b1(0+)$/) {
1829 24         68 my $count = length($1); # 0b100 => len('00') => 2
1830 24         38 my $cnt = $count; # counter for loop
1831 24         66 unshift @$x, 0; # add one element, together with one
1832             # more below in the loop this makes 2
1833 24         61 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 99         173 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 99         233 $c -> _sqrt($x);
1841             }
1842              
1843             # $x is now one element too big, so truncate result by removing it.
1844 24         46 shift @$x;
1845              
1846 24         93 return $x;
1847             }
1848              
1849 17         48 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 17         54 my $x_str = $c -> _str($x);
1863 17         113 my $xm = "." . $x_str;
1864 17         49 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 17         167 my $log10x = log($xm) / log(10) + $xe;
1876 17         59 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 17         49 my $ye = int $log10y;
1882 17         94 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 17 50       56 if ($DEBUG) {
1888 0         0 print "\n";
1889 0         0 print "xm = $xm\n";
1890 0         0 print "xe = $xe\n";
1891 0         0 print "log10x = $log10x\n";
1892 0         0 print "log10y = $log10y\n";
1893 0         0 print "ym = $ym\n";
1894 0         0 print "ye = $ye\n";
1895 0         0 print "\n";
1896             }
1897              
1898 17 50       62 my $d = $ye < 15 ? $ye : 15;
1899 17         43 $ym *= 10 ** $d;
1900 17         49 $ye -= $d;
1901              
1902 17         93 my $y_str = sprintf('%.0f', $ym) . "0" x $ye;
1903 17         42 my $y = $c -> _new($y_str);
1904              
1905 17 50       54 if ($DEBUG) {
1906 0         0 print "ym = $ym\n";
1907 0         0 print "ye = $ye\n";
1908 0         0 print "\n";
1909 0         0 print "y_str = $y_str (initial guess)\n";
1910 0         0 print "\n";
1911             }
1912              
1913             # See if our guess y is correct.
1914              
1915 17         66 my $trial = $c -> _pow($c -> _copy($y), $n);
1916 17         76 my $acmp = $c -> _acmp($trial, $x);
1917              
1918 17 100       80 if ($acmp == 0) {
1919 5         17 @$x = @$y;
1920 5         28 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 12         30 my $lower;
1927             my $upper;
1928              
1929 12         57 my $delta = $c -> _new("1" . ("0" x $ye));
1930 12         70 my $two = $c -> _two();
1931              
1932 12 100       61 if ($acmp < 0) {
    50          
1933 7         14 $lower = $y;
1934 7         24 while ($acmp < 0) {
1935 7         18 $upper = $c -> _add($c -> _copy($lower), $delta);
1936              
1937 7 50       49 if ($DEBUG) {
1938 0         0 print "lower = $lower\n";
1939 0         0 print "upper = $upper\n";
1940 0         0 print "delta = $delta\n";
1941 0         0 print "\n";
1942             }
1943 7         36 $acmp = $c -> _acmp($c -> _pow($c -> _copy($upper), $n), $x);
1944 7 50       82 if ($acmp == 0) {
1945 0         0 @$x = @$upper;
1946 0         0 return $x;
1947             }
1948 7         23 $delta = $c -> _mul($delta, $two);
1949             }
1950             }
1951              
1952             elsif ($acmp > 0) {
1953 5         9 $upper = $y;
1954 5         17 while ($acmp > 0) {
1955 5 50       12 if ($c -> _acmp($upper, $delta) <= 0) {
1956 0         0 $lower = $c -> _zero();
1957 0         0 last;
1958             }
1959 5         23 $lower = $c -> _sub($c -> _copy($upper), $delta);
1960              
1961 5 50       40 if ($DEBUG) {
1962 0         0 print "lower = $lower\n";
1963 0         0 print "upper = $upper\n";
1964 0         0 print "delta = $delta\n";
1965 0         0 print "\n";
1966             }
1967 5         21 $acmp = $c -> _acmp($c -> _pow($c -> _copy($lower), $n), $x);
1968 5 50       53 if ($acmp == 0) {
1969 0         0 @$x = @$lower;
1970 0         0 return $x;
1971             }
1972 5         23 $delta = $c -> _mul($delta, $two);
1973             }
1974             }
1975              
1976             # Use bisection to narrow down the interval.
1977              
1978 12         41 my $one = $c -> _one();
1979             {
1980              
1981 12         26 $delta = $c -> _sub($c -> _copy($upper), $lower);
  12         37  
1982 12 50       66 if ($c -> _acmp($delta, $one) <= 0) {
1983 12         46 @$x = @$lower;
1984 12         65 return $x;
1985             }
1986              
1987 0 0       0 if ($DEBUG) {
1988 0         0 print "lower = $lower\n";
1989 0         0 print "upper = $upper\n";
1990 0         0 print "delta = $delta\n";
1991 0         0 print "\n";
1992             }
1993              
1994 0         0 $delta = $c -> _div($delta, $two);
1995 0         0 my $middle = $c -> _add($c -> _copy($lower), $delta);
1996              
1997 0         0 $acmp = $c -> _acmp($c -> _pow($c -> _copy($middle), $n), $x);
1998 0 0       0 if ($acmp < 0) {
    0          
1999 0         0 $lower = $middle;
2000             } elsif ($acmp > 0) {
2001 0         0 $upper = $middle;
2002             } else {
2003 0         0 @$x = @$middle;
2004 0         0 return $x;
2005             }
2006              
2007 0         0 redo;
2008             }
2009              
2010 0         0 $x;
2011             }
2012              
2013             ##############################################################################
2014             # binary stuff
2015              
2016             sub _and {
2017 130     130   303 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 130 100       377 return $x if $c->_acmp($x, $y) == 0; # shortcut
2023              
2024 66         220 my $m = $c->_one();
2025 66         126 my ($xr, $yr);
2026 66         135 my $mask = $AND_MASK;
2027              
2028 66         168 my $x1 = $c->_copy($x);
2029 66         188 my $y1 = $c->_copy($y);
2030 66         221 my $z = $c->_zero();
2031              
2032 51     51   489 use integer;
  51         153  
  51         315  
2033 66   100     195 until ($c->_is_zero($x1) || $c->_is_zero($y1)) {
2034 53         204 ($x1, $xr) = $c->_div($x1, $mask);
2035 53         212 ($y1, $yr) = $c->_div($y1, $mask);
2036              
2037 53         310 $c->_add($z, $c->_mul([ 0 + $xr->[0] & 0 + $yr->[0] ], $m));
2038 53         181 $c->_mul($m, $mask);
2039             }
2040              
2041 66         231 @$x = @$z;
2042 66         286 return $x;
2043             }
2044              
2045             sub _xor {
2046 194     194   436 my ($c, $x, $y) = @_;
2047              
2048 194 100       500 return $c->_zero() if $c->_acmp($x, $y) == 0; # shortcut (see -and)
2049              
2050 130         356 my $m = $c->_one();
2051 130         239 my ($xr, $yr);
2052 130         213 my $mask = $XOR_MASK;
2053              
2054 130         288 my $x1 = $c->_copy($x);
2055 130         293 my $y1 = $c->_copy($y); # make copy
2056 130         337 my $z = $c->_zero();
2057              
2058 51     51   11706 use integer;
  51         193  
  51         258  
2059 130   100     330 until ($c->_is_zero($x1) || $c->_is_zero($y1)) {
2060 81         269 ($x1, $xr) = $c->_div($x1, $mask);
2061 81         360 ($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 81         343 $c->_add($z, $c->_mul([ 0 + $xr->[0] ^ 0 + $yr->[0] ], $m));
2068 81         258 $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 130 100       326 $c->_add($z, $c->_mul($x1, $m) ) if !$c->_is_zero($x1);
2074 130 100       290 $c->_add($z, $c->_mul($y1, $m) ) if !$c->_is_zero($y1);
2075              
2076 130         301 @$x = @$z;
2077 130         534 return $x;
2078             }
2079              
2080             sub _or {
2081 189     189   418 my ($c, $x, $y) = @_;
2082              
2083 189 100       517 return $x if $c->_acmp($x, $y) == 0; # shortcut (see _and)
2084              
2085 125         351 my $m = $c->_one();
2086 125         220 my ($xr, $yr);
2087 125         211 my $mask = $OR_MASK;
2088              
2089 125         269 my $x1 = $c->_copy($x);
2090 125         314 my $y1 = $c->_copy($y); # make copy
2091 125         312 my $z = $c->_zero();
2092              
2093 51     51   12928 use integer;
  51         139  
  51         295  
2094 125   100     329 until ($c->_is_zero($x1) || $c->_is_zero($y1)) {
2095 80         249 ($x1, $xr) = $c->_div($x1, $mask);
2096 80         199 ($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 80         349 $c->_add($z, $c->_mul([ 0 + $xr->[0] | 0 + $yr->[0] ], $m));
2102 80         245 $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 125 100       356 $c->_add($z, $c->_mul($x1, $m) ) if !$c->_is_zero($x1);
2108 125 100       272 $c->_add($z, $c->_mul($y1, $m) ) if !$c->_is_zero($y1);
2109              
2110 125         291 @$x = @$z;
2111 125         513 return $x;
2112             }
2113              
2114             sub _as_hex {
2115             # convert a decimal number to hex (ref to array, return ref to string)
2116 261     261   519 my ($c, $x) = @_;
2117              
2118 261 100 100     1095 return "0x0" if @$x == 1 && $x->[0] == 0;
2119              
2120 218         480 my $x1 = $c->_copy($x);
2121              
2122 218         432 my $x10000 = [ 0x10000 ];
2123              
2124 218         339 my $es = '';
2125 218         324 my $xr;
2126 218   100     756 until (@$x1 == 1 && $x1->[0] == 0) { # _is_zero()
2127 274         697 ($x1, $xr) = $c->_div($x1, $x10000);
2128 274         1714 $es = sprintf('%04x', $xr->[0]) . $es;
2129             }
2130             #$es = reverse $es;
2131 218         863 $es =~ s/^0*/0x/;
2132 218         811 return $es;
2133             }
2134              
2135             sub _as_bin {
2136             # convert a decimal number to bin (ref to array, return ref to string)
2137 1144     1144   2414 my ($c, $x) = @_;
2138              
2139 1144 100 100     4149 return "0b0" if @$x == 1 && $x->[0] == 0;
2140              
2141 1095         2543 my $x1 = $c->_copy($x);
2142              
2143 1095         2101 my $x10000 = [ 0x10000 ];
2144              
2145 1095         1831 my $es = '';
2146 1095         1481 my $xr;
2147              
2148 1095   100     4918 until (@$x1 == 1 && $x1->[0] == 0) { # _is_zero()
2149 1175         3131 ($x1, $xr) = $c->_div($x1, $x10000);
2150 1175         9039 $es = sprintf('%016b', $xr->[0]) . $es;
2151             }
2152 1095         5056 $es =~ s/^0*/0b/;
2153 1095         3941 return $es;
2154             }
2155              
2156             sub _as_oct {
2157             # convert a decimal number to octal (ref to array, return ref to string)
2158 56     56   125 my ($c, $x) = @_;
2159              
2160 56 100 100     263 return "00" if @$x == 1 && $x->[0] == 0;
2161              
2162 46         125 my $x1 = $c->_copy($x);
2163              
2164 46         106 my $x1000 = [ 1 << 15 ]; # 15 bits = 32768 = 0100000
2165              
2166 46         80 my $es = '';
2167 46         73 my $xr;
2168 46   100     203 until (@$x1 == 1 && $x1->[0] == 0) { # _is_zero()
2169 104         263 ($x1, $xr) = $c->_div($x1, $x1000);
2170 104         648 $es = sprintf("%05o", $xr->[0]) . $es;
2171             }
2172 46         212 $es =~ s/^0*/0/; # excactly one leading zero
2173 46         187 return $es;
2174             }
2175              
2176             sub _from_oct {
2177             # convert a octal number to decimal (string, return ref to array)
2178 13     13   38 my ($c, $os) = @_;
2179              
2180 13         35 my $m = $c->_new(1 << 30); # 30 bits at a time (<32 bits!)
2181 13         30 my $d = 10; # 10 octal digits at a time
2182              
2183 13         37 my $mul = $c->_one();
2184 13         33 my $x = $c->_zero();
2185              
2186 13         44 my $len = int((length($os) - 1) / $d); # $d digit parts, w/o the '0'
2187 13         20 my $val;
2188 13         41 my $i = -$d;
2189 13         61 while ($len >= 0) {
2190 20         48 $val = substr($os, $i, $d); # get oct digits
2191 20         66 $val = CORE::oct($val);
2192 20         26 $i -= $d;
2193 20         34 $len --;
2194 20         41 my $adder = $c -> _new($val);
2195 20 100       69 $c->_add($x, $c->_mul($adder, $mul)) if $val != 0;
2196 20 100       88 $c->_mul($mul, $m) if $len >= 0; # skip last mul
2197             }
2198 13         61 $x;
2199             }
2200              
2201             sub _from_hex {
2202             # convert a hex number to decimal (string, return ref to array)
2203 1470     1470   2957 my ($c, $hs) = @_;
2204              
2205 1470         2986 my $m = $c->_new(0x10000000); # 28 bit at a time (<32 bit!)
2206 1470         2526 my $d = 7; # 7 hexadecimal digits at a time
2207 1470         3192 my $mul = $c->_one();
2208 1470         3011 my $x = $c->_zero();
2209              
2210 1470         4014 my $len = int((length($hs) - 2) / $d); # $d digit parts, w/o the '0x'
2211 1470         2199 my $val;
2212 1470         2356 my $i = -$d;
2213 1470         3167 while ($len >= 0) {
2214 2227         4476 $val = substr($hs, $i, $d); # get hex digits
2215 2227 100       7242 $val =~ s/^0x// if $len == 0; # for last part only because
2216 2227         4310 $val = CORE::hex($val); # hex does not like wrong chars
2217 2227         2968 $i -= $d;
2218 2227         3041 $len --;
2219 2227         4146 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 2227 50       4901 if (CORE::length($val) > $BASE_LEN) {
2223 0         0 $adder = $c->_new($val);
2224             }
2225 2227 100       5975 $c->_add($x, $c->_mul($adder, $mul)) if $val != 0;
2226 2227 100       6670 $c->_mul($mul, $m) if $len >= 0; # skip last mul
2227             }
2228 1470         4426 $x;
2229             }
2230              
2231             sub _from_bin {
2232             # convert a hex number to decimal (string, return ref to array)
2233 248     248   533 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 248         399 my $hs = $bs;
2239 248         1047 $hs =~ s/^[+-]?0b//; # remove sign and 0b
2240 248         461 my $l = length($hs); # bits
2241 248 100       1019 $hs = '0' x (8 - ($l % 8)) . $hs if ($l % 8) != 0; # padd left side w/ 0
2242 248         1440 my $h = '0x' . unpack('H*', pack ('B*', $hs)); # repack as hex
2243              
2244 248         714 $c->_from_hex($h);
2245             }
2246              
2247             ##############################################################################
2248             # special modulus functions
2249              
2250             sub _modinv {
2251              
2252             # modular multiplicative inverse
2253 124     124   270 my ($c, $x, $y) = @_;
2254              
2255             # modulo zero
2256 124 50       254 if ($c->_is_zero($y)) {
2257 0         0 return;
2258             }
2259              
2260             # modulo one
2261 124 50       276 if ($c->_is_one($y)) {
2262 0         0 return $c->_zero(), '+';
2263             }
2264              
2265 124         282 my $u = $c->_zero();
2266 124         294 my $v = $c->_one();
2267 124         301 my $a = $c->_copy($y);
2268 124         268 my $b = $c->_copy($x);
2269              
2270             # Euclid's Algorithm for bgcd(), only that we calc bgcd() ($a) and the result
2271             # ($u) at the same time. See comments in BigInt for why this works.
2272 124         190 my $q;
2273 124         223 my $sign = 1;
2274             {
2275 124         234 ($a, $q, $b) = ($b, $c->_div($a, $b)); # step 1
  269         601  
2276 269 100       625 last if $c->_is_zero($b);
2277              
2278 145         328 my $t = $c->_add( # step 2:
2279             $c->_mul($c->_copy($v), $q), # t = v * q
2280             $u); # + u
2281 145         335 $u = $v; # u = v
2282 145         204 $v = $t; # v = t
2283 145         213 $sign = -$sign;
2284 145         228 redo;
2285             }
2286              
2287             # if the gcd is not 1, then return NaN
2288 124 100       276 return unless $c->_is_one($a);
2289              
2290 103 100       573 ($v, $sign == 1 ? '+' : '-');
2291             }
2292              
2293             sub _modpow {
2294             # modulus of power ($x ** $y) % $z
2295 432     432   961 my ($c, $num, $exp, $mod) = @_;
2296              
2297             # a^b (mod 1) = 0 for all a and b
2298 432 100       946 if ($c->_is_one($mod)) {
2299 150         363 @$num = 0;
2300 150         378 return $num;
2301             }
2302              
2303             # 0^a (mod m) = 0 if m != 0, a != 0
2304             # 0^0 (mod m) = 1 if m != 0
2305 282 100       636 if ($c->_is_zero($num)) {
2306 36 100       94 if ($c->_is_zero($exp)) {
2307 9         28 @$num = 1;
2308             } else {
2309 27         84 @$num = 0;
2310             }
2311 36         105 return $num;
2312             }
2313              
2314             # $num = $c->_mod($num, $mod); # this does not make it faster
2315              
2316 246         611 my $acc = $c->_copy($num);
2317 246         562 my $t = $c->_one();
2318              
2319 246         590 my $expbin = $c->_as_bin($exp);
2320 246         768 $expbin =~ s/^0b//;
2321 246         425 my $len = length($expbin);
2322 246         544 while (--$len >= 0) {
2323 951 100       2295 if (substr($expbin, $len, 1) eq '1') { # is_odd
2324 507         1168 $t = $c->_mul($t, $acc);
2325 507         1203 $t = $c->_mod($t, $mod);
2326             }
2327 951         2072 $acc = $c->_mul($acc, $acc);
2328 951         2030 $acc = $c->_mod($acc, $mod);
2329             }
2330 246         564 @$num = @$t;
2331 246         723 $num;
2332             }
2333              
2334             sub _gcd {
2335             # Greatest common divisor.
2336              
2337 88     88   200 my ($c, $x, $y) = @_;
2338              
2339             # gcd(0, 0) = 0
2340             # gcd(0, a) = a, if a != 0
2341              
2342 88 100 66     399 if (@$x == 1 && $x->[0] == 0) {
2343 8 100 66     77 if (@$y == 1 && $y->[0] == 0) {
2344 4         16 @$x = 0;
2345             } else {
2346 4         20 @$x = @$y;
2347             }
2348 8         27 return $x;
2349             }
2350              
2351             # Until $y is zero ...
2352              
2353 80   66     347 until (@$y == 1 && $y->[0] == 0) {
2354              
2355             # Compute remainder.
2356              
2357 226         588 $c->_mod($x, $y);
2358              
2359             # Swap $x and $y.
2360              
2361 226         427 my $tmp = $c->_copy($x);
2362 226         485 @$x = @$y;
2363 226         803 $y = $tmp; # no deref here; that would modify input $y
2364             }
2365              
2366 80         262 return $x;
2367             }
2368              
2369             1;
2370              
2371             =pod
2372              
2373             =head1 NAME
2374              
2375             Math::BigInt::Calc - pure Perl module to support Math::BigInt
2376              
2377             =head1 SYNOPSIS
2378              
2379             # to use it with Math::BigInt
2380             use Math::BigInt lib => 'Calc';
2381              
2382             # to use it with Math::BigFloat
2383             use Math::BigFloat lib => 'Calc';
2384              
2385             # to use it with Math::BigRat
2386             use Math::BigRat lib => 'Calc';
2387              
2388             # explicitly set base length and whether to "use integer"
2389             use Math::BigInt::Calc base_len => 4, use_int => 1;
2390             use Math::BigInt lib => 'Calc';
2391              
2392             =head1 DESCRIPTION
2393              
2394             Math::BigInt::Calc inherits from Math::BigInt::Lib.
2395              
2396             In this library, the numbers are represented interenally in base B = 10**N,
2397             where N is the largest possible integer that does not cause overflow in the
2398             intermediate computations. The base B elements are stored in an array, with the
2399             least significant element stored in array element zero. There are no leading
2400             zero elements, except a single zero element when the number is zero. For
2401             instance, if B = 10000, the number 1234567890 is represented internally as
2402             [7890, 3456, 12].
2403              
2404             =head1 OPTIONS
2405              
2406             When the module is loaded, it computes the maximum exponent, i.e., power of 10,
2407             that can be used with and without "use integer" in the computations. The default
2408             is to use this maximum exponent. If the combination of the 'base_len' value and
2409             the 'use_int' value exceeds the maximum value, an error is thrown.
2410              
2411             =over 4
2412              
2413             =item base_len
2414              
2415             The base length can be specified explicitly with the 'base_len' option. The
2416             value must be a positive integer.
2417              
2418             use Math::BigInt::Calc base_len => 4; # use 10000 as internal base
2419              
2420             =item use_int
2421              
2422             This option is used to specify whether "use integer" should be used in the
2423             internal computations. The value is interpreted as a boolean value, so use 0 or
2424             "" for false and anything else for true. If the 'base_len' is not specified
2425             together with 'use_int', the current value for the base length is used.
2426              
2427             use Math::BigInt::Calc use_int => 1; # use "use integer" internally
2428              
2429             =back
2430              
2431             =head1 METHODS
2432              
2433             This overview constains only the methods that are specific to
2434             C. For the other methods, see L.
2435              
2436             =over 4
2437              
2438             =item _base_len()
2439              
2440             Specify the desired base length and whether to enable "use integer" in the
2441             computations.
2442              
2443             Math::BigInt::Calc -> _base_len($base_len, $use_int);
2444              
2445             Note that it is better to specify the base length and whether to use integers as
2446             options when the module is loaded, for example like this
2447              
2448             use Math::BigInt::Calc base_len => 6, use_int => 1;
2449              
2450             =back
2451              
2452             =head1 SEE ALSO
2453              
2454             L for a description of the API.
2455              
2456             Alternative libraries L, L,
2457             L, L, and L.
2458              
2459             Some of the modules that use these libraries L,
2460             L, and L.
2461              
2462             =cut