1# This is a rather minimalistic library, whose purpose is to test inheritance
2# from its parent class.
3
4package Math::BigInt::Lib::Minimal;
5
6use 5.006001;
7use strict;
8use warnings;
9
10use Carp;
11use Math::BigInt::Lib;
12
13our @ISA = ('Math::BigInt::Lib');
14
15my $BASE_LEN = 5;
16my $BASE     = 0 + ("1" . ("0" x $BASE_LEN));
17my $MAX_VAL  = $BASE - 1;
18
19sub _new {
20    my ($class, $str) = @_;
21    croak "Invalid input string '$str'" unless $str =~ /^([1-9]\d*|0)\z/;
22
23    my $n = length $str;
24    my $p = int($n / $BASE_LEN);
25    my $q = $n % $BASE_LEN;
26
27    my $format = $] < 5.008 ? "a$BASE_LEN" x $p
28                            : "(a$BASE_LEN)*";
29    $format = "a$q" . $format if $q > 0;
30
31    my $self = [ reverse(map { 0 + $_ } unpack($format, $str)) ];
32    return bless $self, $class;
33}
34
35##############################################################################
36# convert to string
37
38sub _str {
39    my ($class, $x) = @_;
40    my $idx = $#$x;             # index of last element
41
42    # Handle first one differently, since it should not have any leading zeros.
43
44    my $str = int($x->[$idx]);
45
46    if ($idx > 0) {
47        my $z = '0' x ($BASE_LEN - 1);
48        while (--$idx >= 0) {
49            $str .= substr($z . $x->[$idx], -$BASE_LEN);
50        }
51    }
52    $str;
53}
54
55##############################################################################
56# actual math code
57
58sub _add {
59    # (ref to int_num_array, ref to int_num_array)
60    #
61    # Routine to add two base 1eX numbers stolen from Knuth Vol 2 Algorithm A
62    # pg 231. There are separate routines to add and sub as per Knuth pg 233.
63    # This routine modifies array x, but not y.
64
65    my ($c, $x, $y) = @_;
66
67    # $x + 0 => $x
68
69    return $x if @$y == 1 && $y->[0] == 0;
70
71    # 0 + $y => $y->copy
72
73    if (@$x == 1 && $x->[0] == 0) {
74        @$x = @$y;
75        return $x;
76    }
77
78    # For each in Y, add Y to X and carry. If after that, something is left in
79    # X, foreach in X add carry to X and then return X, carry. Trades one
80    # "$j++" for having to shift arrays.
81
82    my $i;
83    my $car = 0;
84    my $j = 0;
85    for $i (@$y) {
86        $x->[$j] -= $BASE if $car = (($x->[$j] += $i + $car) >= $BASE) ? 1 : 0;
87        $j++;
88    }
89    while ($car != 0) {
90        $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0;
91        $j++;
92    }
93
94    $x;
95}
96
97sub _sub {
98    # (ref to int_num_array, ref to int_num_array, swap)
99    #
100    # Subtract base 1eX numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
101    # subtract Y from X by modifying x in place
102    my ($c, $sx, $sy, $s) = @_;
103
104    my $car = 0;
105    my $i;
106    my $j = 0;
107    if (!$s) {
108        for $i (@$sx) {
109            last unless defined $sy->[$j] || $car;
110            $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0);
111            $j++;
112        }
113        # might leave leading zeros, so fix that
114        return __strip_zeros($sx);
115    }
116    for $i (@$sx) {
117        # We can't do an early out if $x < $y, since we need to copy the high
118        # chunks from $y. Found by Bob Mathews.
119        #last unless defined $sy->[$j] || $car;
120        $sy->[$j] += $BASE
121          if $car = ($sy->[$j] = $i - ($sy->[$j] || 0) - $car) < 0;
122        $j++;
123    }
124    # might leave leading zeros, so fix that
125    __strip_zeros($sy);
126}
127
128# The following _mul function is an exact copy of _mul_use_div_64 in
129# Math::BigInt::Calc.
130
131sub _mul {
132    # (ref to int_num_array, ref to int_num_array)
133    # multiply two numbers in internal representation
134    # modifies first arg, second need not be different from first
135    # works for 64 bit integer with "use integer"
136    my ($c, $xv, $yv) = @_;
137
138    use integer;
139    if (@$yv == 1) {
140        # shortcut for two small numbers, also handles $x == 0
141        if (@$xv == 1) {
142            # shortcut for two very short numbers (improved by Nathan Zook)
143            # works also if xv and yv are the same reference, and handles also $x == 0
144            if (($xv->[0] *= $yv->[0]) >= $BASE) {
145                $xv->[0] =
146                  $xv->[0] - ($xv->[1] = $xv->[0] / $BASE) * $BASE;
147            }
148            return $xv;
149        }
150        # $x * 0 => 0
151        if ($yv->[0] == 0) {
152            @$xv = (0);
153            return $xv;
154        }
155        # multiply a large number a by a single element one, so speed up
156        my $y = $yv->[0];
157        my $car = 0;
158        foreach my $i (@$xv) {
159            #$i = $i * $y + $car; $car = $i / $BASE; $i -= $car * $BASE;
160            $i = $i * $y + $car;
161            $i -= ($car = $i / $BASE) * $BASE;
162        }
163        push @$xv, $car if $car != 0;
164        return $xv;
165    }
166    # shortcut for result $x == 0 => result = 0
167    return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) );
168
169    # since multiplying $x with $x fails, make copy in this case
170    $yv = $c->_copy($xv) if $xv == $yv; # same references?
171
172    my @prod = ();
173    my ($prod, $car, $cty, $xi, $yi);
174    for $xi (@$xv) {
175        $car = 0;
176        $cty = 0;
177        # looping through this if $xi == 0 is silly - so optimize it away!
178        $xi = (shift @prod || 0), next if $xi == 0;
179        for $yi (@$yv) {
180            $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
181            $prod[$cty++] = $prod - ($car = $prod / $BASE) * $BASE;
182        }
183        $prod[$cty] += $car if $car; # need really to check for 0?
184        $xi = shift @prod || 0;      # || 0 makes v5.005_3 happy
185    }
186    push @$xv, @prod;
187    $xv;
188}
189
190# The following _div function is an exact copy of _div_use_div_64 in
191# Math::BigInt::Calc.
192
193sub _div {
194    # ref to array, ref to array, modify first array and return remainder if
195    # in list context
196    # This version works on 64 bit integers
197    my ($c, $x, $yorg) = @_;
198
199    use integer;
200    # the general div algorithm here is about O(N*N) and thus quite slow, so
201    # we first check for some special cases and use shortcuts to handle them.
202
203    # This works, because we store the numbers in a chunked format where each
204    # element contains 5..7 digits (depending on system).
205
206    # if both numbers have only one element:
207    if (@$x == 1 && @$yorg == 1) {
208        # shortcut, $yorg and $x are two small numbers
209        if (wantarray) {
210            my $rem = [ $x->[0] % $yorg->[0] ];
211            bless $rem, $c;
212            $x->[0] = int($x->[0] / $yorg->[0]);
213            return ($x, $rem);
214        } else {
215            $x->[0] = int($x->[0] / $yorg->[0]);
216            return $x;
217        }
218    }
219    # if x has more than one, but y has only one element:
220    if (@$yorg == 1) {
221        my $rem;
222        $rem = $c->_mod($c->_copy($x), $yorg) if wantarray;
223
224        # shortcut, $y is < $BASE
225        my $j = @$x;
226        my $r = 0;
227        my $y = $yorg->[0];
228        my $b;
229        while ($j-- > 0) {
230            $b = $r * $BASE + $x->[$j];
231            $x->[$j] = int($b/$y);
232            $r = $b % $y;
233        }
234        pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero
235        return ($x, $rem) if wantarray;
236        return $x;
237    }
238    # now x and y have more than one element
239
240    # check whether y has more elements than x, if yet, the result will be 0
241    if (@$yorg > @$x) {
242        my $rem;
243        $rem = $c->_copy($x) if wantarray;    # make copy
244        @$x = 0;                        # set to 0
245        return ($x, $rem) if wantarray; # including remainder?
246        return $x;                      # only x, which is [0] now
247    }
248    # check whether the numbers have the same number of elements, in that case
249    # the result will fit into one element and can be computed efficiently
250    if (@$yorg == @$x) {
251        my $rem;
252        # if $yorg has more digits than $x (it's leading element is longer than
253        # the one from $x), the result will also be 0:
254        if (length(int($yorg->[-1])) > length(int($x->[-1]))) {
255            $rem = $c->_copy($x) if wantarray;     # make copy
256            @$x = 0;                          # set to 0
257            return ($x, $rem) if wantarray; # including remainder?
258            return $x;
259        }
260        # now calculate $x / $yorg
261
262        if (length(int($yorg->[-1])) == length(int($x->[-1]))) {
263            # same length, so make full compare
264
265            my $a = 0;
266            my $j = @$x - 1;
267            # manual way (abort if unequal, good for early ne)
268            while ($j >= 0) {
269                last if ($a = $x->[$j] - $yorg->[$j]);
270                $j--;
271            }
272            # $a contains the result of the compare between X and Y
273            # a < 0: x < y, a == 0: x == y, a > 0: x > y
274            if ($a <= 0) {
275                $rem = $c->_zero();                  # a = 0 => x == y => rem 0
276                $rem = $c->_copy($x) if $a != 0;       # a < 0 => x < y => rem = x
277                @$x = 0;                       # if $a < 0
278                $x->[0] = 1 if $a == 0;        # $x == $y
279                return ($x, $rem) if wantarray; # including remainder?
280                return $x;
281            }
282            # $x >= $y, so proceed normally
283        }
284    }
285
286    # all other cases:
287
288    my $y = $c->_copy($yorg);         # always make copy to preserve
289
290    my ($car, $bar, $prd, $dd, $xi, $yi, @q, $v2, $v1, @d, $tmp, $q, $u2, $u1, $u0);
291
292    $car = $bar = $prd = 0;
293    if (($dd = int($BASE / ($y->[-1] + 1))) != 1) {
294        for $xi (@$x) {
295            $xi = $xi * $dd + $car;
296            $xi -= ($car = int($xi / $BASE)) * $BASE;
297        }
298        push(@$x, $car);
299        $car = 0;
300        for $yi (@$y) {
301            $yi = $yi * $dd + $car;
302            $yi -= ($car = int($yi / $BASE)) * $BASE;
303        }
304    } else {
305        push(@$x, 0);
306    }
307
308    # @q will accumulate the final result, $q contains the current computed
309    # part of the final result
310
311    @q = ();
312    ($v2, $v1) = @$y[-2, -1];
313    $v2 = 0 unless $v2;
314    while ($#$x > $#$y) {
315        ($u2, $u1, $u0) = @$x[-3..-1];
316        $u2 = 0 unless $u2;
317        #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n"
318        # if $v1 == 0;
319        $q = (($u0 == $v1) ? $MAX_VAL : int(($u0 * $BASE + $u1) / $v1));
320        --$q while ($v2 * $q > ($u0 * $BASE +$ u1- $q*$v1) * $BASE + $u2);
321        if ($q) {
322            ($car, $bar) = (0, 0);
323            for ($yi = 0, $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) {
324                $prd = $q * $y->[$yi] + $car;
325                $prd -= ($car = int($prd / $BASE)) * $BASE;
326                $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0));
327            }
328            if ($x->[-1] < $car + $bar) {
329                $car = 0;
330                --$q;
331                for ($yi = 0, $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) {
332                    $x->[$xi] -= $BASE
333                      if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE));
334                }
335            }
336        }
337        pop(@$x);
338        unshift(@q, $q);
339    }
340    if (wantarray) {
341        my $d = bless [], $c;
342        if ($dd != 1) {
343            $car = 0;
344            for $xi (reverse @$x) {
345                $prd = $car * $BASE + $xi;
346                $car = $prd - ($tmp = int($prd / $dd)) * $dd;
347                unshift(@$d, $tmp);
348            }
349        } else {
350            @$d = @$x;
351        }
352        @$x = @q;
353        __strip_zeros($x);
354        __strip_zeros($d);
355        return ($x, $d);
356    }
357    @$x = @q;
358    __strip_zeros($x);
359    $x;
360}
361
362# The following _mod function is an exact copy of _mod in Math::BigInt::Calc.
363
364sub _mod {
365    # if possible, use mod shortcut
366    my ($c, $x, $yo) = @_;
367
368    # slow way since $y too big
369    if (@$yo > 1) {
370        my ($xo, $rem) = $c->_div($x, $yo);
371        @$x = @$rem;
372        return $x;
373    }
374
375    my $y = $yo->[0];
376
377    # if both are single element arrays
378    if (@$x == 1) {
379        $x->[0] %= $y;
380        return $x;
381    }
382
383    # if @$x has more than one element, but @$y is a single element
384    my $b = $BASE % $y;
385    if ($b == 0) {
386        # when BASE % Y == 0 then (B * BASE) % Y == 0
387        # (B * BASE) % $y + A % Y => A % Y
388        # so need to consider only last element: O(1)
389        $x->[0] %= $y;
390    } elsif ($b == 1) {
391        # else need to go through all elements in @$x: O(N), but loop is a bit
392        # simplified
393        my $r = 0;
394        foreach (@$x) {
395            $r = ($r + $_) % $y; # not much faster, but heh...
396            #$r += $_ % $y; $r %= $y;
397        }
398        $r = 0 if $r == $y;
399        $x->[0] = $r;
400    } else {
401        # else need to go through all elements in @$x: O(N)
402        my $r = 0;
403        my $bm = 1;
404        foreach (@$x) {
405            $r = ($_ * $bm + $r) % $y;
406            $bm = ($bm * $b) % $y;
407
408            #$r += ($_ % $y) * $bm;
409            #$bm *= $b;
410            #$bm %= $y;
411            #$r %= $y;
412        }
413        $r = 0 if $r == $y;
414        $x->[0] = $r;
415    }
416    @$x = $x->[0];              # keep one element of @$x
417    return $x;
418}
419
420sub __strip_zeros {
421    # Internal normalization function that strips leading zeros from the array.
422    # Args: ref to array
423    my $x = shift;
424
425    push @$x, 0 if @$x == 0;    # div might return empty results, so fix it
426    return $x if @$x == 1;      # early out
427
428    #print "strip: cnt $cnt i $i\n";
429    # '0', '3', '4', '0', '0',
430    #  0    1    2    3    4
431    # cnt = 5, i = 4
432    # i = 4
433    # i = 3
434    # => fcnt = cnt - i (5-2 => 3, cnt => 5-1 = 4, throw away from 4th pos)
435    # >= 1: skip first part (this can be zero)
436
437    my $i = $#$x;
438    while ($i > 0) {
439        last if $x->[$i] != 0;
440        $i--;
441    }
442    $i++;
443    splice(@$x, $i) if $i < @$x;
444    $x;
445}
446
447###############################################################################
448# check routine to test internal state for corruptions
449
450sub _check {
451    # used by the test suite
452    my ($class, $x) = @_;
453
454    return "Undefined" unless defined $x;
455    return "$x is not a reference" unless ref($x);
456    return "Not an '$class'" unless ref($x) eq $class;
457
458    for (my $i = 0 ; $i <= $#$x ; ++ $i) {
459        my $e = $x -> [$i];
460
461        return "Element at index $i is undefined"
462          unless defined $e;
463
464        return "Element at index $i is a '" . ref($e) .
465          "', which is not a scalar"
466          unless ref($e) eq "";
467
468        return "Element at index $i is '$e', which does not look like an" .
469          " normal integer"
470            #unless $e =~ /^([1-9]\d*|0)\z/;
471            unless $e =~ /^\d+\z/;
472
473        return "Element at index $i is '$e', which is negative"
474          if $e < 0;
475
476        return "Element at index $i is '$e', which is not smaller than" .
477          " the base '$BASE'"
478            if $e >= $BASE;
479
480        return "Element at index $i (last element) is zero"
481          if $#$x > 0 && $i == $#$x && $e == 0;
482    }
483
484    return 0;
485}
486
4871;
488