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