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   154665 use 5.006001;
  51         204  
4 51     51   321 use strict;
  51         122  
  51         1315  
5 51     51   326 use warnings;
  51         103  
  51         1926  
6              
7 51     51   332 use Carp qw< carp croak >;
  51         148  
  51         3446  
8 51     51   37850 use Math::BigInt::Lib;
  51         153  
  51         260  
9              
10             our $VERSION = '1.999842';
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   3060 shift;
93              
94 73 100       296 if (@_) { # if called as setter ...
95 62         158 my ($base_len, $use_int) = @_;
96              
97 62 50 33     753 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     703 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         766 $BASE = 0 + ("1" . ("0" x $BASE_LEN));
112 62         152 $MAX_VAL = $BASE - 1;
113 62 100       297 $USE_INT = $use_int ? 1 : 0;
114              
115             {
116 51     51   487 no warnings "redefine";
  51         193  
  51         46039  
  62         139  
117 62 100       255 if ($use_int) {
118 61         311 *_mul = \&_mul_use_int;
119 61         219 *_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         167 my $umax = ~0; # largest unsigned integer
133 73 50       260 my $tmp = $umax < $BASE ? $umax : $BASE;
134              
135 73         128 $MAX_BITS = 0;
136 73         270 while ($tmp >>= 1) {
137 2065         3192 $MAX_BITS++;
138             }
139              
140             # Limit to 32 bits for portability. Is this really necessary? XXX
141              
142 73 50       315 $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         317 for ($AND_BITS = $MAX_BITS ; $AND_BITS > 0 ; $AND_BITS--) {
148 73         448 my $x = CORE::oct('0b' . '1' x $AND_BITS);
149 73         165 my $y = $x & $x;
150 73         266 my $z = 2 * (2 ** ($AND_BITS - 1)) + 1;
151 73 0 33     385 last unless $AND_BITS < $MAX_BITS && $x == $z && $y == $x;
      33        
152             }
153              
154 73         322 for ($XOR_BITS = $MAX_BITS ; $XOR_BITS > 0 ; $XOR_BITS--) {
155 73         235 my $x = CORE::oct('0b' . '1' x $XOR_BITS);
156 73         170 my $y = $x ^ $x;
157 73         196 my $z = 2 * (2 ** ($XOR_BITS - 1)) + 1;
158 73 0 33     428 last unless $XOR_BITS < $MAX_BITS && $x == $z && $y == $x;
      33        
159             }
160              
161 73         320 for ($OR_BITS = $MAX_BITS ; $OR_BITS > 0 ; $OR_BITS--) {
162 73         279 my $x = CORE::oct('0b' . '1' x $OR_BITS);
163 73         167 my $y = $x | $x;
164 73         183 my $z = 2 * (2 ** ($OR_BITS - 1)) + 1;
165 73 0 33     397 last unless $OR_BITS < $MAX_BITS && $x == $z && $y == $x;
      33        
166             }
167              
168 73         304 $AND_MASK = __PACKAGE__->_new(( 2 ** $AND_BITS ));
169 73         287 $XOR_MASK = __PACKAGE__->_new(( 2 ** $XOR_BITS ));
170 73         252 $OR_MASK = __PACKAGE__->_new(( 2 ** $OR_BITS ));
171              
172 73 100       64516 return $BASE_LEN unless wantarray;
173 6         56 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   431396 my ($class, $str) = @_;
183             #unless ($str =~ /^([1-9]\d*|0)\z/) {
184             # croak("Invalid input string '$str'");
185             #}
186              
187 188716         302318 my $input_len = length($str) - 1;
188              
189             # Shortcut for small numbers.
190 188716 100       607117 return bless [ $str ], $class if $input_len < $BASE_LEN;
191              
192 27265         62690 my $format = "a" . (($input_len % $BASE_LEN) + 1);
193 27265 50       65077 $format .= $] < 5.008 ? "a$BASE_LEN" x int($input_len / $BASE_LEN)
194             : "(a$BASE_LEN)*";
195              
196 27265         168840 my $self = [ reverse(map { 0 + $_ } unpack($format, $str)) ];
  294991         555084  
197 27265         117248 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   354 for ($MAX_EXP_F = 1 ; ; $MAX_EXP_F++) { # when $MAX_EXP_F = 5
224 510         763 my $MAX_EXP_FM1 = $MAX_EXP_F - 1; # = 4
225 510         1123 my $bs = "1" . ("0" x $MAX_EXP_F); # = "100000"
226 510         854 my $xs = "9" x $MAX_EXP_F; # = "99999"
227 510         828 my $cs = ("9" x $MAX_EXP_FM1) . "8"; # = "99998"
228 510         945 my $ys = $cs . ("0" x $MAX_EXP_FM1) . "1"; # = "9999800001"
229              
230             # Compute and check the product.
231 510         921 my $yn = $xs * $xs; # = 9999800001
232 510 50       1146 last if $yn != $ys;
233              
234             # Compute and check the remainder.
235 510         1746 my $rn = $yn % $bs; # = 1
236 510 100       1048 last if $rn != 1;
237              
238             # Compute and check the carry. The division here is exact.
239 459         750 my $cn = ($yn - $rn) / $bs; # = 99998
240 459 50       1045 last if $cn != $cs;
241              
242             # Compute and check product plus carry.
243 459         839 my $zs = $cs . ("9" x $MAX_EXP_F); # = "9999899999"
244 459         645 my $zn = $yn + $cn; # = 99998999999
245 459 50       906 last if $zn != $zs;
246 459 50       1080 last if $zn - ($zn - 1) != 1;
247             }
248 51         147 $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         135 my $umax = ~0; # largest unsigned integer
259 51         473 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         117 my $MAX_EXP_IM1 = $MAX_EXP_I - 1; # = 4
264 51         215 my $bs = "1" . ("0" x $MAX_EXP_I); # = "100000"
265 51         562 my $xs = "9" x $MAX_EXP_I; # = "99999"
266 51         251 my $cs = ("9" x $MAX_EXP_IM1) . "8"; # = "99998"
267 51         188 my $ys = $cs . ("0" x $MAX_EXP_IM1) . "1"; # = "9999800001"
268              
269             # Compute and check the product.
270 51         155 my $yn = $xs * $xs; # = 9999800001
271 51 50       233 next if $yn != $ys;
272              
273             # Compute and check the remainder.
274 51         173 my $rn = $yn % $bs; # = 1
275 51 50       261 next if $rn != 1;
276              
277             # Compute and check the carry. The division here is exact.
278 51         157 my $cn = ($yn - $rn) / $bs; # = 99998
279 51 50       265 next if $cn != $cs;
280              
281             # Compute and check product plus carry.
282 51         186 my $zs = $cs . ("9" x $MAX_EXP_I); # = "9999899999"
283 51         104 my $zn = $yn + $cn; # = 99998999999
284 51 50       194 next if $zn != $zs;
285 51 50       333 next if $zn - ($zn - 1) != 1;
286 51         181 last;
287             }
288              
289 51 50       278 ($BASE_LEN, $USE_INT) = $MAX_EXP_F > $MAX_EXP_I
290             ? ($MAX_EXP_F, 0) : ($MAX_EXP_I, 1);
291              
292 51         391 __PACKAGE__ -> _base_len($BASE_LEN, $USE_INT);
293             }
294              
295             ###############################################################################
296              
297             sub _zero {
298             # create a zero
299 45807     45807   70942 my $class = shift;
300 45807         137264 return bless [ 0 ], $class;
301             }
302              
303             sub _one {
304             # create a one
305 5064     5064   8217 my $class = shift;
306 5064         13093 return bless [ 1 ], $class;
307             }
308              
309             sub _two {
310             # create a two
311 2316     2316   3756 my $class = shift;
312 2316         6403 return bless [ 2 ], $class;
313             }
314              
315             sub _ten {
316             # create a 10
317 29997     29997   50032 my $class = shift;
318 29997 50       66897 my $self = $BASE_LEN == 1 ? [ 0, 1 ] : [ 10 ];
319 29997         80010 bless $self, $class;
320             }
321              
322             sub _1ex {
323             # create a 1Ex
324 5     5   15 my $class = shift;
325              
326 5         8 my $rem = $_[0] % $BASE_LEN; # remainder
327 5         13 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         36 bless [ (0) x $div, 0 + ("1" . ("0" x $rem)) ], $class;
332             }
333              
334             sub _copy {
335             # make a true copy
336 104520     104520   161461 my $class = shift;
337 104520         137769 return bless [ @{ $_[0] } ], $class;
  104520         309631  
338             }
339              
340             sub import {
341 11     11   285 my $self = shift;
342              
343 11         31 my $opts;
344 11         30 my ($base_len, $use_int);
345 11         65 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       4 croak "Missing value for parameter '$param'"
350             unless @_;
351 2         4 my $value = shift;
352              
353 2 50 66     8 if ($param eq 'base_len' || $param eq 'use_int') {
354 2         4 $opts -> {$param} = $value;
355 2         5 next;
356             }
357              
358 0         0 croak "Unknown parameter '$param'";
359             }
360              
361 11 100       44 $base_len = exists $opts -> {base_len} ? $opts -> {base_len} : $BASE_LEN;
362 11 100       49 $use_int = exists $opts -> {use_int} ? $opts -> {use_int} : $USE_INT;
363 11         42 __PACKAGE__ -> _base_len($base_len, $use_int);
364              
365 11         9355 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   101406 my $ary = $_[1];
376 61653         101246 my $idx = $#$ary; # index of last element
377              
378 61653 50       124642 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         107051 my $ret = int($ary->[$idx]);
384 61653 100       125411 if ($idx > 0) {
385             # Interestingly, the pre-padd method uses more time.
386             # The old grep variant takes longer (14 vs. 10 sec).
387 27502         60452 my $z = '0' x ($BASE_LEN - 1);
388 27502         58110 while (--$idx >= 0) {
389 269390         593885 $ret .= substr($z . $ary->[$idx], -$BASE_LEN);
390             }
391             }
392 61653         146921 $ret;
393             }
394              
395             sub _num {
396             # Make a Perl scalar number (int/float) from a BigInt object.
397 74823     74823   117129 my $x = $_[1];
398              
399 74823 100       212888 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         32 my $num = 0;
407 16         59 for (my $i = $#$x ; $i >= 0 ; --$i) {
408 41         62 $num *= $BASE;
409 41         97 $num += $x -> [$i];
410             }
411 16         43 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   101275 my ($c, $x, $y) = @_;
425              
426             # $x + 0 => $x
427              
428 55282 100 100     191989 return $x if @$y == 1 && $y->[0] == 0;
429              
430             # 0 + $y => $y->copy
431              
432 48411 100 100     140557 if (@$x == 1 && $x->[0] == 0) {
433 7339         17179 @$x = @$y;
434 7339         17089 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         57676 my $car = 0;
442 41072         55148 my $j = 0;
443 41072         71356 for my $i (@$y) {
444 78962 100       179515 $x->[$j] -= $BASE if $car = (($x->[$j] += $i + $car) >= $BASE) ? 1 : 0;
    100          
445 78962         115545 $j++;
446             }
447 41072         80563 while ($car != 0) {
448 345 100       1853 $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0;
    100          
449 345         669 $j++;
450             }
451 41072         93323 $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   8978 my ($c, $x) = @_;
458              
459 4592         8685 for my $i (@$x) {
460 4605 100       15086 return $x if ($i += 1) < $BASE; # early out
461 18         34 $i = 0; # overflow, next
462             }
463 5 50       36 push @$x, 1 if $x->[-1] == 0; # last overflowed, so extend
464 5         14 $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   1864 my ($c, $x) = @_;
471              
472 831         1339 my $MAX = $BASE - 1; # since MAX_VAL based on BASE
473 831         1596 for my $i (@$x) {
474 847 100       2117 last if ($i -= 1) >= 0; # early out
475 16         27 $i = $MAX; # underflow, next
476             }
477 831 100 100     2401 pop @$x if $x->[-1] == 0 && @$x > 1; # last underflowed (but leave 0)
478 831         1581 $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   109547 my ($c, $sx, $sy, $s) = @_;
487              
488 55071         80136 my $car = 0;
489 55071         73299 my $j = 0;
490 55071 100       102792 if (!$s) {
491 48976         90953 for my $i (@$sx) {
492 69195 100 100     148641 last unless defined $sy->[$j] || $car;
493 67632 100 100     191096 $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0);
494 67632         106218 $j++;
495             }
496             # might leave leading zeros, so fix that
497 48976         96798 return __strip_zeros($sx);
498             }
499 6095         11815 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     24208 $sy->[$j] += $BASE
504             if $car = ($sy->[$j] = $i - ($sy->[$j] || 0) - $car) < 0;
505 6173         10741 $j++;
506             }
507             # might leave leading zeros, so fix that
508 6095         11422 __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   103725 my ($c, $xv, $yv) = @_;
517 51     51   31560 use integer;
  51         887  
  51         335  
518              
519 54307 100       118569 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 42431 100       78101 if (@$xv == 1) {
523 32102 100       73227 if (($xv->[0] *= $yv->[0]) >= $BASE) {
524 1417         5027 $xv->[0] =
525             $xv->[0] - ($xv->[1] = $xv->[0] / $BASE) * $BASE;
526             }
527 32102         68953 return $xv;
528             }
529             # $x * 0 => 0
530 10329 100       23058 if ($yv->[0] == 0) {
531 15         70 @$xv = (0);
532 15         74 return $xv;
533             }
534              
535             # multiply a large number a by a single element one, so speed up
536 10314         17513 my $y = $yv->[0];
537 10314         15219 my $car = 0;
538 10314         19033 foreach my $i (@$xv) {
539             #$i = $i * $y + $car; $car = $i / $BASE; $i -= $car * $BASE;
540 57807         75627 $i = $i * $y + $car;
541 57807         85902 $i -= ($car = $i / $BASE) * $BASE;
542             }
543 10314 100       21107 push @$xv, $car if $car != 0;
544 10314         26674 return $xv;
545             }
546              
547             # shortcut for result $x == 0 => result = 0
548 11876 100 100     30068 return $xv if @$xv == 1 && $xv->[0] == 0;
549              
550             # since multiplying $x with $x fails, make copy in this case
551 11605 100       33730 $yv = $c->_copy($xv) if $xv == $yv; # same references?
552              
553 11605         21537 my @prod = ();
554 11605         18083 my ($prod, $car, $cty);
555 11605         20682 for my $xi (@$xv) {
556 89839         113753 $car = 0;
557 89839         108235 $cty = 0;
558             # looping through this if $xi == 0 is silly - so optimize it away!
559 89839 100 100     148472 $xi = (shift(@prod) || 0), next if $xi == 0;
560 88142         124968 for my $yi (@$yv) {
561 1219407   100     2013645 $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
562 1219407         1757435 $prod[$cty++] = $prod - ($car = $prod / $BASE) * $BASE;
563             }
564 88142 100       152478 $prod[$cty] += $car if $car; # need really to check for 0?
565 88142   100     164222 $xi = shift(@prod) || 0; # || 0 makes v5.005_3 happy
566             }
567 11605         26492 push @$xv, @prod;
568 11605         31535 $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   32213 use integer;
  51         160  
  51         268  
640              
641 15346     15346   31686 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     41727 if (@$x == 1 && @$yorg == 1) {
648             # shortcut, $yorg and $x are two small numbers
649 2917 100       5766 if (wantarray) {
650 2612         7194 my $rem = [ $x->[0] % $yorg->[0] ];
651 2612         4454 bless $rem, $c;
652 2612         4737 $x->[0] = $x->[0] / $yorg->[0];
653 2612         7418 return ($x, $rem);
654             } else {
655 305         714 $x->[0] = $x->[0] / $yorg->[0];
656 305         700 return $x;
657             }
658             }
659              
660             # if x has more than one, but y has only one element:
661 12429 100       25467 if (@$yorg == 1) {
662 3439         5213 my $rem;
663 3439 100       7171 $rem = $c->_mod($c->_copy($x), $yorg) if wantarray;
664              
665             # shortcut, $y is < $BASE
666 3439         5196 my $j = @$x;
667 3439         4699 my $r = 0;
668 3439         5795 my $y = $yorg->[0];
669 3439         4629 my $b;
670 3439         7380 while ($j-- > 0) {
671 108954         137176 $b = $r * $BASE + $x->[$j];
672 108954         133796 $r = $b % $y;
673 108954         181258 $x->[$j] = $b / $y;
674             }
675 3439 100 66     14221 pop(@$x) if @$x > 1 && $x->[-1] == 0; # remove any trailing zero
676 3439 100       7122 return ($x, $rem) if wantarray;
677 3096         8431 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 8990 100       19863 if (@$yorg > @$x) {
684 248         342 my $rem;
685 248 100       670 $rem = $c->_copy($x) if wantarray; # make copy
686 248         507 @$x = 0; # set to 0
687 248 100       1051 return ($x, $rem) if wantarray; # including remainder?
688 7         19 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 8742 100       17421 if (@$yorg == @$x) {
694 784         1465 my $cmp = 0;
695 784         2197 for (my $j = $#$x ; $j >= 0 ; --$j) {
696 913 100       2377 last if $cmp = $x->[$j] - $yorg->[$j];
697             }
698              
699 784 100       1667 if ($cmp == 0) { # x = y
700 21         80 @$x = 1;
701 21 100       111 return $x, $c->_zero() if wantarray;
702 8         41 return $x;
703             }
704              
705 763 100       1730 if ($cmp < 0) { # x < y
706 445 100       996 if (wantarray) {
707 21         53 my $rem = $c->_copy($x);
708 21         58 @$x = 0;
709 21         78 return $x, $rem;
710             }
711 424         882 @$x = 0;
712 424         821 return $x;
713             }
714             }
715              
716             # all other cases:
717              
718 8276         18207 my $y = $c->_copy($yorg); # always make copy to preserve
719              
720 8276         12431 my $tmp;
721 8276         15530 my $dd = $BASE / ($y->[-1] + 1);
722 8276 100       15690 if ($dd != 1) {
723 8087         11236 my $car = 0;
724 8087         15069 for my $xi (@$x) {
725 96727         121430 $xi = $xi * $dd + $car;
726 96727         134442 $xi -= ($car = $xi / $BASE) * $BASE;
727             }
728 8087         15065 push(@$x, $car);
729 8087         11304 $car = 0;
730 8087         13281 for my $yi (@$y) {
731 44777         56906 $yi = $yi * $dd + $car;
732 44777         64044 $yi -= ($car = $yi / $BASE) * $BASE;
733             }
734             } else {
735 189         825 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 8276         13494 my @q = ();
742 8276         18140 my ($v2, $v1) = @$y[-2, -1];
743 8276 100       16474 $v2 = 0 unless $v2;
744 8276         18990 while ($#$x > $#$y) {
745 61707         112699 my ($u2, $u1, $u0) = @$x[-3 .. -1];
746 61707 100       106158 $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 61707         85879 my $tmp = $u0 * $BASE + $u1;
750 61707         80948 my $rem = $tmp % $v1;
751 61707 100       105538 my $q = $u0 == $v1 ? $MAX_VAL : (($tmp - $rem) / $v1);
752 61707         132094 --$q while $v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2;
753 61707 100       101186 if ($q) {
754 57039         68401 my $prd;
755 57039         82698 my ($car, $bar) = (0, 0);
756 57039         125561 for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) {
757 485734         637989 $prd = $q * $y->[$yi] + $car;
758 485734         619795 $prd -= ($car = int($prd / $BASE)) * $BASE;
759 485734 100       1147714 $x->[$xi] += $BASE if $bar = (($x->[$xi] -= $prd + $bar) < 0);
760             }
761 57039 100       114327 if ($x->[-1] < $car + $bar) {
762 17         53 $car = 0;
763 17         36 --$q;
764 17         101 for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) {
765 103 100       291 $x->[$xi] -= $BASE
766             if $car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE);
767             }
768             }
769             }
770 61707         81795 pop(@$x);
771 61707         140263 unshift(@q, $q);
772             }
773              
774 8276 100       16695 if (wantarray) {
775 1254         2241 my $d = bless [], $c;
776 1254 100       2208 if ($dd != 1) {
777 1246         1638 my $car = 0;
778 1246         1571 my $prd;
779 1246         2091 for my $xi (reverse @$x) {
780 4792         6053 $prd = $car * $BASE + $xi;
781 4792         6116 $car = $prd - ($tmp = $prd / $dd) * $dd;
782 4792         7624 unshift @$d, $tmp;
783             }
784             } else {
785 8         25 @$d = @$x;
786             }
787 1254         2812 @$x = @q;
788 1254         2975 __strip_zeros($x);
789 1254         2466 __strip_zeros($d);
790 1254         4392 return ($x, $d);
791             }
792 7022         20645 @$x = @q;
793 7022         18189 __strip_zeros($x);
794 7022         25462 $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 110675     110675   200924 my ($c, $cx, $cy) = @_;
970              
971             # shortcut for short numbers
972 110675 100 100     466714 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 18528   100     61169 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 18528 100       43136 return -1 if $lxy < 0; # already differs, ret
983 15593 100       36552 return 1 if $lxy > 0; # ditto
984              
985             # manual way (abort if unequal, good for early ne)
986 11533         14849 my $a;
987 11533         16302 my $j = @$cx;
988 11533         21941 while (--$j >= 0) {
989 37831 100       78629 last if $a = $cx->[$j] - $cy->[$j];
990             }
991 11533         43701 $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   166727 my $cx = $_[1];
1000              
1001 103112         317600 (@$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   271 my ($c, $x, $n) = @_;
1008              
1009 97         207 my $len = _len('', $x);
1010              
1011 97 100       248 $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     389 return "0" if $n < 0 || $n >= $len; # return 0 for digits out of range
1017              
1018 95         205 my $elem = int($n / $BASE_LEN); # index of array element
1019 95         170 my $digit = $n % $BASE_LEN; # index of digit within the element
1020 95         1158 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   2070351 my $x = $_[1];
1029              
1030 78937 100 100     228043 return 0 if @$x == 1 && $x->[0] == 0;
1031              
1032 76485         113321 my $zeros = 0;
1033 76485         141064 foreach my $elem (@$x) {
1034 222025 100       376767 if ($elem != 0) {
1035 76485         345523 $elem =~ /[^0](0*)\z/;
1036 76485         181898 $zeros += length($1); # count trailing zeros
1037 76485         119351 last; # early out
1038             }
1039 145540         194313 $zeros += $BASE_LEN;
1040             }
1041 76485         160137 $zeros;
1042             }
1043              
1044             ##############################################################################
1045             # _is_* routines
1046              
1047             sub _is_zero {
1048             # return true if arg is zero
1049 384382 100 100 384382   531891 @{$_[1]} == 1 && $_[1]->[0] == 0 ? 1 : 0;
1050             }
1051              
1052             sub _is_even {
1053             # return true if arg is even
1054 86 100   86   1019 $_[1]->[0] % 2 ? 0 : 1;
1055             }
1056              
1057             sub _is_odd {
1058             # return true if arg is odd
1059 706 100   706   4075 $_[1]->[0] % 2 ? 1 : 0;
1060             }
1061              
1062             sub _is_one {
1063             # return true if arg is one
1064 6213 100 100 6213   9913 @{$_[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   1098 @{$_[1]} == 1 && $_[1]->[0] == 2 ? 1 : 0;
1070             }
1071              
1072             sub _is_ten {
1073             # return true if arg is ten
1074 2 50   2   7 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 64610     64610   108375 my $x = shift;
1085              
1086 64610 100       128938 push @$x, 0 if @$x == 0; # div might return empty results, so fix it
1087 64610 100       181734 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 13064         19661 my $i = $#$x;
1099 13064         27004 while ($i > 0) {
1100 22079 100       41949 last if $x->[$i] != 0;
1101 9502         16476 $i--;
1102             }
1103 13064         17751 $i++;
1104 13064 100       28035 splice(@$x, $i) if $i < @$x;
1105 13064         24115 $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   1934876 my ($class, $x) = @_;
1114              
1115 5498         19461 my $msg = $class -> SUPER::_check($x);
1116 5498 100       13055 return $msg if $msg;
1117              
1118 5497         8186 my $n;
1119 5497         8843 eval { $n = @$x };
  5497         10188  
1120 5497 50       13207 return "Not an array reference" unless $@ eq '';
1121              
1122 5497 50       11272 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         15675 for (my $i = 0 ; $i <= $#$x ; ++ $i) {
1130 6292         11098 my $e = $x -> [$i];
1131              
1132 6292 50       12155 return "Element at index $i is undefined"
1133             unless defined $e;
1134              
1135 6292 50       12703 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       22500 return "Element at index $i is '$e', which does not look like an" .
1143             " normal integer" unless $e =~ /^\d+\z/;
1144              
1145 6292 50       13337 return "Element at index $i is '$e', which is not smaller than" .
1146             " the base '$BASE'" if $e >= $BASE;
1147              
1148 6292 50 100     26861 return "Element at index $i (last element) is zero"
      66        
1149             if $#$x > 0 && $i == $#$x && $e == 0;
1150             }
1151              
1152 5497         13219 return 0;
1153             }
1154              
1155             ###############################################################################
1156              
1157             sub _mod {
1158             # if possible, use mod shortcut
1159 2985     2985   5712 my ($c, $x, $yo) = @_;
1160              
1161             # slow way since $y too big
1162 2985 100       6043 if (@$yo > 1) {
1163 805         1738 my ($xo, $rem) = $c->_div($x, $yo);
1164 805         1579 @$x = @$rem;
1165 805         1997 return $x;
1166             }
1167              
1168 2180         3621 my $y = $yo->[0];
1169              
1170             # if both are single element arrays
1171 2180 100       4268 if (@$x == 1) {
1172 1654         2816 $x->[0] %= $y;
1173 1654         3788 return $x;
1174             }
1175              
1176             # if @$x has more than one element, but @$y is a single element
1177 526         1064 my $b = $BASE % $y;
1178 526 100       1417 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         35 $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         242 my $r = 0;
1187 155         350 foreach (@$x) {
1188 310         535 $r = ($r + $_) % $y; # not much faster, but heh...
1189             #$r += $_ % $y; $r %= $y;
1190             }
1191 155 50       332 $r = 0 if $r == $y;
1192 155         285 $x->[0] = $r;
1193             } else {
1194             # else need to go through all elements in @$x: O(N)
1195 356         574 my $r = 0;
1196 356         574 my $bm = 1;
1197 356         736 foreach (@$x) {
1198 2555         3369 $r = ($_ * $bm + $r) % $y;
1199 2555         3796 $bm = ($bm * $b) % $y;
1200              
1201             #$r += ($_ % $y) * $bm;
1202             #$bm *= $b;
1203             #$bm %= $y;
1204             #$r %= $y;
1205             }
1206 356 50       814 $r = 0 if $r == $y;
1207 356         657 $x->[0] = $r;
1208             }
1209 526         1242 @$x = $x->[0]; # keep one element of @$x
1210 526         1140 return $x;
1211             }
1212              
1213             ##############################################################################
1214             # shifts
1215              
1216             sub _rsft {
1217 29993     29993   60964 my ($c, $x, $n, $b) = @_;
1218 29993 50 33     67380 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       81293 $b = $c->_new($b) unless ref $b;
1223              
1224 29993 100       70094 if ($c -> _acmp($b, $c -> _ten())) {
1225 49         175 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         59555 my $dst = 0; # destination
1231 29944         66275 my $src = $c->_num($n); # as normal int
1232 29944         73073 my $xlen = (@$x - 1) * $BASE_LEN + length(int($x->[-1]));
1233 29944 100 33     97827 if ($src >= $xlen or ($src == $xlen and !defined $x->[1])) {
      66        
1234             # 12345 67890 shifted right by more than 10 digits => 0
1235 165         401 splice(@$x, 1); # leave only one element
1236 165         336 $x->[0] = 0; # set to zero
1237 165         550 return $x;
1238             }
1239 29779         48106 my $rem = $src % $BASE_LEN; # remainder to shift
1240 29779         62339 $src = int($src / $BASE_LEN); # source
1241 29779 100       52054 if ($rem == 0) {
1242 1701         4139 splice(@$x, 0, $src); # even faster, 38.4 => 39.3
1243             } else {
1244 28078         43342 my $len = @$x - $src; # elems to go
1245 28078         37075 my $vd;
1246 28078         53795 my $z = '0' x $BASE_LEN;
1247 28078         66077 $x->[ @$x ] = 0; # avoid || 0 test inside loop
1248 28078         56883 while ($dst < $len) {
1249 180903         256216 $vd = $z . $x->[$src];
1250 180903         282963 $vd = substr($vd, -$BASE_LEN, $BASE_LEN - $rem);
1251 180903         220399 $src++;
1252 180903         345205 $vd = substr($z . $x->[$src], -$rem, $rem) . $vd;
1253 180903 50       332008 $vd = substr($vd, -$BASE_LEN, $BASE_LEN) if length($vd) > $BASE_LEN;
1254 180903         282219 $x->[$dst] = int($vd);
1255 180903         307592 $dst++;
1256             }
1257 28078 50       73242 splice(@$x, $dst) if $dst > 0; # kill left-over array elems
1258 28078 100 66     92922 pop(@$x) if $x->[-1] == 0 && @$x > 1; # kill last element if 0
1259             } # else rem == 0
1260 29779         92497 $x;
1261             }
1262              
1263             sub _lsft {
1264 23383     23383   48438 my ($c, $x, $n, $b) = @_;
1265              
1266 23383 100 100     49277 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       57198 $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         46343 my $bstr = $c->_str($b);
1276 19451 100       90449 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         47800 my $log10b = length($1);
1282 19423         41466 $n = $c->_mul($c->_new($log10b), $n);
1283 19423         44319 $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         45176 my $r = $n % $BASE_LEN;
1290 19423         38890 my $q = ($n - $r) / $BASE_LEN;
1291              
1292             # If we must shift the values within the elements ...
1293              
1294 19423 100       39506 if ($r) {
1295 17766         27047 my $i = @$x; # index
1296 17766         35060 $x->[$i] = 0; # initialize most significant element
1297 17766         35719 my $z = '0' x $BASE_LEN;
1298 17766         24552 my $vd;
1299 17766         38232 while ($i >= 0) {
1300 134602         186143 $vd = $x->[$i];
1301 134602         212432 $vd = $z . $vd;
1302 134602         231231 $vd = substr($vd, $r - $BASE_LEN, $BASE_LEN - $r);
1303 134602 100       289860 $vd .= $i > 0 ? substr($z . $x->[$i - 1], -$BASE_LEN, $r)
1304             : '0' x $r;
1305 134602 50       229980 $vd = substr($vd, -$BASE_LEN, $BASE_LEN) if length($vd) > $BASE_LEN;
1306 134602         212675 $x->[$i] = int($vd); # e.g., "0...048" -> 48 etc.
1307 134602         226715 $i--;
1308             }
1309              
1310 17766 100       41334 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       39814 if ($q) {
1316 15563         58627 unshift @$x, (0) x $q;
1317             }
1318              
1319             } else {
1320 28         110 $x = $c->_mul($x, $c->_pow($b, $n));
1321             }
1322              
1323 19451         66008 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   2436 my ($c, $cx, $cy) = @_;
1330              
1331 1014 100 66     4349 if (@$cy == 1 && $cy->[0] == 0) {
1332 64         173 splice(@$cx, 1);
1333 64         152 $cx->[0] = 1; # y == 0 => x => 1
1334 64         183 return $cx;
1335             }
1336              
1337 950 100 100     5864 if ((@$cx == 1 && $cx->[0] == 1) || # x == 1
      66        
      100        
1338             (@$cy == 1 && $cy->[0] == 1)) # or y == 1
1339             {
1340 144         440 return $cx;
1341             }
1342              
1343 806 100 100     2794 if (@$cx == 1 && $cx->[0] == 0) {
1344 1         5 splice (@$cx, 1);
1345 1         3 $cx->[0] = 0; # 0 ** y => 0 (if not y <= 0)
1346 1         4 return $cx;
1347             }
1348              
1349 805         1944 my $pow2 = $c->_one();
1350              
1351 805         2331 my $y_bin = $c->_as_bin($cy);
1352 805         2739 $y_bin =~ s/^0b//;
1353 805         1462 my $len = length($y_bin);
1354 805         1926 while (--$len > 0) {
1355 1869 100       4939 $c->_mul($pow2, $cx) if substr($y_bin, $len, 1) eq '1'; # is odd?
1356 1869         3956 $c->_mul($cx, $cx);
1357             }
1358              
1359 805         2351 $c->_mul($cx, $pow2);
1360 805         2597 $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   129 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         92 my $twok = $c->_mul($c->_two(), $c->_copy($k)); # 2 * k
  56         148  
1375 56 100       182 if ($c->_acmp($twok, $n) > 0) { # if 2*k > n
1376 28         81 $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       210 if ($c->_is_zero($k)) {
1387 21         73 @$n = 1;
1388             } else {
1389              
1390             # Make a copy of the original n, since we'll be modifying n in-place.
1391              
1392 35         296 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         144 $c->_inc($n);
1398              
1399 35         75 my $f = $c->_copy($n);
1400 35         105 $c->_inc($f);
1401              
1402 35         99 my $d = $c->_two();
1403              
1404             # while f <= n (the original n, that is) ...
1405              
1406 35         100 while ($c->_acmp($f, $n_orig) <= 0) {
1407              
1408             # n = (n * f / d) == 5 * 6 / 2 (cf. example above)
1409              
1410 105         280 $c->_mul($n, $f);
1411 105         270 $c->_div($n, $d);
1412              
1413             # f = 7, d = 3 (cf. example above)
1414              
1415 105         355 $c->_inc($f);
1416 105         189 $c->_inc($d);
1417             }
1418              
1419             }
1420              
1421 56         520 return $n;
1422             }
1423              
1424             sub _fac {
1425             # factorial of $x
1426             # ref to array, return ref to array
1427 140     140   378 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       345 if (@$cx == 1) {
1433 140         449 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       434 if ($cx->[0] <= $#factorials) {
1447 69         185 my $tmp = $c -> _new($factorials[ $cx->[0] ]);
1448 69         205 @$cx = @$tmp;
1449 69         262 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       212 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     666 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         137 my $zero_elements = 0;
1484              
1485             # If n is even, set n = n -1
1486 55         174 my $k = $c->_num($cx);
1487 55         148 my $even = 1;
1488 55 100       184 if (($k & 1) == 0) {
1489 35         67 $even = $k;
1490 35         72 $k --;
1491             }
1492             # set k to the center point
1493 55         146 $k = ($k + 1) / 2;
1494             # print "k $k even: $even\n";
1495             # now calculate k * k
1496 55         97 my $k2 = $k * $k;
1497 55         95 my $odd = 1;
1498 55         248 my $sum = 1;
1499 55         115 my $i = $k - 1;
1500             # keep reference to x
1501 55         271 my $new_x = $c->_new($k * $even);
1502 55         177 @$cx = @$new_x;
1503 55 50       174 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         84 my $j = 1;
1510 55         133 while ($j <= $i) {
1511 282         425 my $m = ($k2 - $sum);
1512 282         376 $odd += 2;
1513 282         362 $sum += $odd;
1514 282         361 $j++;
1515 282   100     1309 while ($j <= $i && ($m < $BASE2) && (($k2 - $sum) < $BASE2)) {
      66        
1516 366         512 $m *= ($k2 - $sum);
1517 366         462 $odd += 2;
1518 366         501 $sum += $odd;
1519 366         1054 $j++;
1520             # print STDERR "\n k2 $k2 m $m sum $sum odd $odd\n"; sleep(1);
1521             }
1522 282 50       501 if ($m < $BASE) {
1523 282         695 $c->_mul($cx, [$m]);
1524             } else {
1525 0         0 $c->_mul($cx, $c->_new($m));
1526             }
1527 282 100       816 if ($cx->[0] == 0) {
1528 10         36 $zero_elements ++;
1529 10         42 shift @$cx;
1530             }
1531             # print STDERR "Calculate $k2 - $sum = $m (x = ", $c->_str($cx), ")\n";
1532             }
1533             # multiply in the zeros again
1534 55         164 unshift @$cx, (0) x $zero_elements;
1535 55         225 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         40 my $steps = 100;
1541 16 50       56 $steps = $cx->[0] if @$cx == 1;
1542 16         37 my $r = 2;
1543 16         46 my $cf = 3;
1544 16         32 my $step = 2;
1545 16         30 my $last = $r;
1546 16   66     110 while ($r * $cf < $BASE && $step < $steps) {
1547 136         185 $last = $r;
1548 136         212 $r *= $cf++;
1549 136         631 $step++;
1550             }
1551 16 50 33     149 if ((@$cx == 1) && $step == $cx->[0]) {
1552             # completely done, so keep reference to $x and return
1553 16         41 $cx->[0] = $r;
1554 16         68 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   182 my ($c, $x, $base) = @_;
1647              
1648             # X == 0 => NaN
1649 85 50 66     335 return if @$x == 1 && $x->[0] == 0;
1650              
1651             # BASE 0 or 1 => NaN
1652 85 50 66     326 return if @$base == 1 && $base->[0] < 2;
1653              
1654             # X == 1 => 0 (is exact)
1655 85 50 66     255 if (@$x == 1 && $x->[0] == 1) {
1656 0         0 @$x = 0;
1657 0         0 return $x, 1;
1658             }
1659              
1660 85         196 my $cmp = $c->_acmp($x, $base);
1661              
1662             # X == BASE => 1 (is exact)
1663 85 50       193 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       208 if ($cmp < 0) {
1670 4         18 @$x = 0;
1671 4         24 return $x, 0;
1672             }
1673              
1674 81         192 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         308 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         175 $log += (@$base - 1) * $BASE_LEN;
1685              
1686             # calculate now a guess based on the values obtained above:
1687 81         267 my $res = $c->_new(int($len / $log));
1688              
1689 81         263 @$x = @$res;
1690 81         181 my $trial = $c->_pow($c->_copy($base), $x);
1691 81         213 my $acmp = $c->_acmp($trial, $x_org);
1692              
1693             # Did we get the exact result?
1694              
1695 81 100       289 return $x, 1 if $acmp == 0;
1696              
1697             # Too small?
1698              
1699 64         170 while ($acmp < 0) {
1700 7         44 $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         129 while ($acmp > 0) {
1708 81         218 $c->_div($trial, $base);
1709 81         232 $c->_dec($x);
1710 81         166 $acmp = $c->_acmp($trial, $x_org);
1711             }
1712              
1713 64 100       265 return $x, 1 if $acmp == 0; # result is exact
1714 19         86 return $x, 0; # result is too small
1715             }
1716              
1717             # for debugging:
1718 51     51   270762 use constant DEBUG => 0;
  51         127  
  51         80837  
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   1981 my ($c, $x) = @_;
1726              
1727 932 100       2122 if (@$x == 1) {
1728             # fits into one Perl scalar, so result can be computed directly
1729 292         965 $x->[0] = int(sqrt($x->[0]));
1730 292         858 return $x;
1731             }
1732              
1733             # Create an initial guess for the square root.
1734              
1735 640         1009 my $s;
1736 640 100       1516 if (@$x % 2) {
1737 225         1012 $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         1191 my $cmp;
1749 640         942 while (1) {
1750 1999         4490 my $sq = $c -> _mul($c -> _copy($s), $s);
1751 1999         4662 $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       4931 if ($cmp > 0) {
    100          
1760 1352         3105 my $num = $c -> _sub($c -> _copy($sq), $x);
1761 1352         3498 my $den = $c -> _mul($c -> _two(), $s);
1762 1352         3529 my $delta = $c -> _div($num, $den);
1763 1352 100       3193 last if $c -> _is_zero($delta);
1764 934         2168 $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         1319 my $num = $c -> _sub($c -> _copy($x), $sq);
1775 538         1801 my $den = $c -> _mul($c -> _two(), $s);
1776 538         1679 my $delta = $c -> _div($num, $den);
1777 538 100       1477 last if $c -> _is_zero($delta);
1778 425         1213 $s = $c -> _add($s, $delta);
1779             }
1780              
1781             # If x(n)*x(n) = y, we have the exact result.
1782              
1783             else {
1784 109         270 last;
1785             }
1786             }
1787              
1788 640 100       2350 $s = $c -> _dec($s) if $cmp > 0; # never overshoot
1789 640         1657 @$x = @$s;
1790 640         1916 return $x;
1791             }
1792              
1793             sub _root {
1794             # Take n'th root of $x in place.
1795              
1796 109     109   476 my ($c, $x, $n) = @_;
1797              
1798             # Small numbers.
1799              
1800 109 100       279 if (@$x == 1) {
1801 68 50 33     335 return $x if $x -> [0] == 0 || $x -> [0] == 1;
1802              
1803 68 50       158 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         382 my $y = int($x->[0] ** (1 / $n->[0]));
1807 68         135 my $yp1 = $y + 1;
1808 68 100       199 $y = $yp1 if $yp1 ** $n->[0] == $x->[0];
1809 68         115 $x->[0] = $y;
1810 68         224 return $x;
1811             }
1812             }
1813              
1814             # If x <= n, the result is always (truncated to) 1.
1815              
1816 41 50 33     229 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         160 my $b = $c -> _as_bin($n);
1828 41 100       247 if ($b =~ /0b1(0+)$/) {
1829 24         78 my $count = length($1); # 0b100 => len('00') => 2
1830 24         50 my $cnt = $count; # counter for loop
1831 24         69 unshift @$x, 0; # add one element, together with one
1832             # more below in the loop this makes 2
1833 24         65 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         163 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         237 $c -> _sqrt($x);
1841             }
1842              
1843             # $x is now one element too big, so truncate result by removing it.
1844 24         40 shift @$x;
1845              
1846 24         89 return $x;
1847             }
1848              
1849 17         42 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         58 my $x_str = $c -> _str($x);
1863 17         74 my $xm = "." . $x_str;
1864 17         37 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         150 my $log10x = log($xm) / log(10) + $xe;
1876 17         56 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         47 my $ye = int $log10y;
1882 17         79 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       54 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       61 my $d = $ye < 15 ? $ye : 15;
1899 17         40 $ym *= 10 ** $d;
1900 17         34 $ye -= $d;
1901              
1902 17         78 my $y_str = sprintf('%.0f', $ym) . "0" x $ye;
1903 17         71 my $y = $c -> _new($y_str);
1904              
1905 17 50       58 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         56 my $trial = $c -> _pow($c -> _copy($y), $n);
1916 17         61 my $acmp = $c -> _acmp($trial, $x);
1917              
1918 17 100       130 if ($acmp == 0) {
1919 5         28 @$x = @$y;
1920 5         26 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         29 my $lower;
1927             my $upper;
1928              
1929 12         82 my $delta = $c -> _new("1" . ("0" x $ye));
1930 12         71 my $two = $c -> _two();
1931              
1932 12 100       66 if ($acmp < 0) {
    50          
1933 7         28 $lower = $y;
1934 7         30 while ($acmp < 0) {
1935 7         20 $upper = $c -> _add($c -> _copy($lower), $delta);
1936              
1937 7 50       30 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         24 $acmp = $c -> _acmp($c -> _pow($c -> _copy($upper), $n), $x);
1944 7 50       46 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         10 $upper = $y;
1954 5         19 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         22 $lower = $c -> _sub($c -> _copy($upper), $delta);
1960              
1961 5 50       26 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         19 $acmp = $c -> _acmp($c -> _pow($c -> _copy($lower), $n), $x);
1968 5 50       30 if ($acmp == 0) {
1969 0         0 @$x = @$lower;
1970 0         0 return $x;
1971             }
1972 5         30 $delta = $c -> _mul($delta, $two);
1973             }
1974             }
1975              
1976             # Use bisection to narrow down the interval.
1977              
1978 12         40 my $one = $c -> _one();
1979             {
1980              
1981 12         20 $delta = $c -> _sub($c -> _copy($upper), $lower);
  12         47  
1982 12 50       75 if ($c -> _acmp($delta, $one) <= 0) {
1983 12         43 @$x = @$lower;
1984 12         72 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   304 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         210 my $m = $c->_one();
2025 66         130 my ($xr, $yr);
2026 66         151 my $mask = $AND_MASK;
2027              
2028 66         162 my $x1 = $c->_copy($x);
2029 66         205 my $y1 = $c->_copy($y);
2030 66         173 my $z = $c->_zero();
2031              
2032 51     51   516 use integer;
  51         118  
  51         290  
2033 66   100     196 until ($c->_is_zero($x1) || $c->_is_zero($y1)) {
2034 53         182 ($x1, $xr) = $c->_div($x1, $mask);
2035 53         151 ($y1, $yr) = $c->_div($y1, $mask);
2036              
2037 53         309 $c->_add($z, $c->_mul([ 0 + $xr->[0] & 0 + $yr->[0] ], $m));
2038 53         225 $c->_mul($m, $mask);
2039             }
2040              
2041 66         207 @$x = @$z;
2042 66         273 return $x;
2043             }
2044              
2045             sub _xor {
2046 194     194   460 my ($c, $x, $y) = @_;
2047              
2048 194 100       522 return $c->_zero() if $c->_acmp($x, $y) == 0; # shortcut (see -and)
2049              
2050 130         377 my $m = $c->_one();
2051 130         232 my ($xr, $yr);
2052 130         204 my $mask = $XOR_MASK;
2053              
2054 130         303 my $x1 = $c->_copy($x);
2055 130         276 my $y1 = $c->_copy($y); # make copy
2056 130         309 my $z = $c->_zero();
2057              
2058 51     51   11363 use integer;
  51         173  
  51         291  
2059 130   100     351 until ($c->_is_zero($x1) || $c->_is_zero($y1)) {
2060 81         281 ($x1, $xr) = $c->_div($x1, $mask);
2061 81         352 ($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         383 $c->_add($z, $c->_mul([ 0 + $xr->[0] ^ 0 + $yr->[0] ], $m));
2068 81         247 $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       341 $c->_add($z, $c->_mul($x1, $m) ) if !$c->_is_zero($x1);
2074 130 100       300 $c->_add($z, $c->_mul($y1, $m) ) if !$c->_is_zero($y1);
2075              
2076 130         306 @$x = @$z;
2077 130         522 return $x;
2078             }
2079              
2080             sub _or {
2081 189     189   442 my ($c, $x, $y) = @_;
2082              
2083 189 100       541 return $x if $c->_acmp($x, $y) == 0; # shortcut (see _and)
2084              
2085 125         372 my $m = $c->_one();
2086 125         243 my ($xr, $yr);
2087 125         199 my $mask = $OR_MASK;
2088              
2089 125         296 my $x1 = $c->_copy($x);
2090 125         283 my $y1 = $c->_copy($y); # make copy
2091 125         314 my $z = $c->_zero();
2092              
2093 51     51   12570 use integer;
  51         133  
  51         304  
2094 125   100     353 until ($c->_is_zero($x1) || $c->_is_zero($y1)) {
2095 80         274 ($x1, $xr) = $c->_div($x1, $mask);
2096 80         248 ($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         407 $c->_add($z, $c->_mul([ 0 + $xr->[0] | 0 + $yr->[0] ], $m));
2102 80         272 $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       345 $c->_add($z, $c->_mul($x1, $m) ) if !$c->_is_zero($x1);
2108 125 100       286 $c->_add($z, $c->_mul($y1, $m) ) if !$c->_is_zero($y1);
2109              
2110 125         287 @$x = @$z;
2111 125         558 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   532 my ($c, $x) = @_;
2117              
2118 261 100 100     1057 return "0x0" if @$x == 1 && $x->[0] == 0;
2119              
2120 218         477 my $x1 = $c->_copy($x);
2121              
2122 218         463 my $x10000 = [ 0x10000 ];
2123              
2124 218         396 my $es = '';
2125 218         325 my $xr;
2126 218   100     787 until (@$x1 == 1 && $x1->[0] == 0) { # _is_zero()
2127 274         646 ($x1, $xr) = $c->_div($x1, $x10000);
2128 274         1686 $es = sprintf('%04x', $xr->[0]) . $es;
2129             }
2130             #$es = reverse $es;
2131 218         850 $es =~ s/^0*/0x/;
2132 218         826 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   2264 my ($c, $x) = @_;
2138              
2139 1144 100 100     4205 return "0b0" if @$x == 1 && $x->[0] == 0;
2140              
2141 1095         2543 my $x1 = $c->_copy($x);
2142              
2143 1095         2131 my $x10000 = [ 0x10000 ];
2144              
2145 1095         1871 my $es = '';
2146 1095         1625 my $xr;
2147              
2148 1095   100     4304 until (@$x1 == 1 && $x1->[0] == 0) { # _is_zero()
2149 1175         3043 ($x1, $xr) = $c->_div($x1, $x10000);
2150 1175         9103 $es = sprintf('%016b', $xr->[0]) . $es;
2151             }
2152 1095         5211 $es =~ s/^0*/0b/;
2153 1095         3909 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   132 my ($c, $x) = @_;
2159              
2160 56 100 100     260 return "00" if @$x == 1 && $x->[0] == 0;
2161              
2162 46         132 my $x1 = $c->_copy($x);
2163              
2164 46         105 my $x1000 = [ 1 << 15 ]; # 15 bits = 32768 = 0100000
2165              
2166 46         84 my $es = '';
2167 46         104 my $xr;
2168 46   100     211 until (@$x1 == 1 && $x1->[0] == 0) { # _is_zero()
2169 104         264 ($x1, $xr) = $c->_div($x1, $x1000);
2170 104         662 $es = sprintf("%05o", $xr->[0]) . $es;
2171             }
2172 46         212 $es =~ s/^0*/0/; # excactly one leading zero
2173 46         223 return $es;
2174             }
2175              
2176             sub _from_oct {
2177             # convert a octal number to decimal (string, return ref to array)
2178 13     13   34 my ($c, $os) = @_;
2179              
2180 13         34 my $m = $c->_new(1 << 30); # 30 bits at a time (<32 bits!)
2181 13         27 my $d = 10; # 10 octal digits at a time
2182              
2183 13         33 my $mul = $c->_one();
2184 13         30 my $x = $c->_zero();
2185              
2186 13         39 my $len = int((length($os) - 1) / $d); # $d digit parts, w/o the '0'
2187 13         28 my $val;
2188 13         27 my $i = -$d;
2189 13         52 while ($len >= 0) {
2190 20         51 $val = substr($os, $i, $d); # get oct digits
2191 20         36 $val = CORE::oct($val);
2192 20         32 $i -= $d;
2193 20         28 $len --;
2194 20         47 my $adder = $c -> _new($val);
2195 20 100       68 $c->_add($x, $c->_mul($adder, $mul)) if $val != 0;
2196 20 100       78 $c->_mul($mul, $m) if $len >= 0; # skip last mul
2197             }
2198 13         60 $x;
2199             }
2200              
2201             sub _from_hex {
2202             # convert a hex number to decimal (string, return ref to array)
2203 1470     1470   3049 my ($c, $hs) = @_;
2204              
2205 1470         2876 my $m = $c->_new(0x10000000); # 28 bit at a time (<32 bit!)
2206 1470         2434 my $d = 7; # 7 hexadecimal digits at a time
2207 1470         3211 my $mul = $c->_one();
2208 1470         3067 my $x = $c->_zero();
2209              
2210 1470         3968 my $len = int((length($hs) - 2) / $d); # $d digit parts, w/o the '0x'
2211 1470         2120 my $val;
2212 1470         2360 my $i = -$d;
2213 1470         3098 while ($len >= 0) {
2214 2227         4376 $val = substr($hs, $i, $d); # get hex digits
2215 2227 100       7150 $val =~ s/^0x// if $len == 0; # for last part only because
2216 2227         4280 $val = CORE::hex($val); # hex does not like wrong chars
2217 2227         3108 $i -= $d;
2218 2227         2849 $len --;
2219 2227         4166 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       4967 if (CORE::length($val) > $BASE_LEN) {
2223 0         0 $adder = $c->_new($val);
2224             }
2225 2227 100       6115 $c->_add($x, $c->_mul($adder, $mul)) if $val != 0;
2226 2227 100       6668 $c->_mul($mul, $m) if $len >= 0; # skip last mul
2227             }
2228 1470         4513 $x;
2229             }
2230              
2231             sub _from_bin {
2232             # convert a hex number to decimal (string, return ref to array)
2233 248     248   554 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         394 my $hs = $bs;
2239 248         1033 $hs =~ s/^[+-]?0b//; # remove sign and 0b
2240 248         472 my $l = length($hs); # bits
2241 248 100       1028 $hs = '0' x (8 - ($l % 8)) . $hs if ($l % 8) != 0; # padd left side w/ 0
2242 248         1359 my $h = '0x' . unpack('H*', pack ('B*', $hs)); # repack as hex
2243              
2244 248         697 $c->_from_hex($h);
2245             }
2246              
2247             ##############################################################################
2248             # special modulus functions
2249              
2250             sub _modinv {
2251              
2252             # modular multiplicative inverse
2253 124     124   273 my ($c, $x, $y) = @_;
2254              
2255             # modulo zero
2256 124 50       256 if ($c->_is_zero($y)) {
2257 0         0 return;
2258             }
2259              
2260             # modulo one
2261 124 50       331 if ($c->_is_one($y)) {
2262 0         0 return $c->_zero(), '+';
2263             }
2264              
2265 124         278 my $u = $c->_zero();
2266 124         280 my $v = $c->_one();
2267 124         302 my $a = $c->_copy($y);
2268 124         271 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         188 my $q;
2273 124         200 my $sign = 1;
2274             {
2275 124         206 ($a, $q, $b) = ($b, $c->_div($a, $b)); # step 1
  269         570  
2276 269 100       591 last if $c->_is_zero($b);
2277              
2278 145         371 my $t = $c->_add( # step 2:
2279             $c->_mul($c->_copy($v), $q), # t = v * q
2280             $u); # + u
2281 145         307 $u = $v; # u = v
2282 145         211 $v = $t; # v = t
2283 145         211 $sign = -$sign;
2284 145         229 redo;
2285             }
2286              
2287             # if the gcd is not 1, then return NaN
2288 124 100       269 return unless $c->_is_one($a);
2289              
2290 103 100       543 ($v, $sign == 1 ? '+' : '-');
2291             }
2292              
2293             sub _modpow {
2294             # modulus of power ($x ** $y) % $z
2295 432     432   1014 my ($c, $num, $exp, $mod) = @_;
2296              
2297             # a^b (mod 1) = 0 for all a and b
2298 432 100       927 if ($c->_is_one($mod)) {
2299 150         387 @$num = 0;
2300 150         369 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       664 if ($c->_is_zero($num)) {
2306 36 100       81 if ($c->_is_zero($exp)) {
2307 9         55 @$num = 1;
2308             } else {
2309 27         90 @$num = 0;
2310             }
2311 36         130 return $num;
2312             }
2313              
2314             # $num = $c->_mod($num, $mod); # this does not make it faster
2315              
2316 246         575 my $acc = $c->_copy($num);
2317 246         545 my $t = $c->_one();
2318              
2319 246         608 my $expbin = $c->_as_bin($exp);
2320 246         790 $expbin =~ s/^0b//;
2321 246         455 my $len = length($expbin);
2322 246         584 while (--$len >= 0) {
2323 951 100       2290 if (substr($expbin, $len, 1) eq '1') { # is_odd
2324 507         1158 $t = $c->_mul($t, $acc);
2325 507         1152 $t = $c->_mod($t, $mod);
2326             }
2327 951         2042 $acc = $c->_mul($acc, $acc);
2328 951         2001 $acc = $c->_mod($acc, $mod);
2329             }
2330 246         631 @$num = @$t;
2331 246         706 $num;
2332             }
2333              
2334             sub _gcd {
2335             # Greatest common divisor.
2336              
2337 88     88   198 my ($c, $x, $y) = @_;
2338              
2339             # gcd(0, 0) = 0
2340             # gcd(0, a) = a, if a != 0
2341              
2342 88 100 66     412 if (@$x == 1 && $x->[0] == 0) {
2343 8 100 66     53 if (@$y == 1 && $y->[0] == 0) {
2344 4         13 @$x = 0;
2345             } else {
2346 4         16 @$x = @$y;
2347             }
2348 8         28 return $x;
2349             }
2350              
2351             # Until $y is zero ...
2352              
2353 80   66     343 until (@$y == 1 && $y->[0] == 0) {
2354              
2355             # Compute remainder.
2356              
2357 226         611 $c->_mod($x, $y);
2358              
2359             # Swap $x and $y.
2360              
2361 226         444 my $tmp = $c->_copy($x);
2362 226         491 @$x = @$y;
2363 226         773 $y = $tmp; # no deref here; that would modify input $y
2364             }
2365              
2366 80         225 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