Win32CORE.c needed windows.h
[p5sagit/p5-mst-13.2.git] / lib / Math / BigInt / Calc.pm
CommitLineData
0716bf9b 1package Math::BigInt::Calc;
2
a0ac753d 3use 5.006002;
0716bf9b 4use strict;
574bacfe 5# use warnings; # dont use warnings for older Perls
0716bf9b 6
50109ad0 7our $VERSION = '0.50';
0716bf9b 8
9# Package to store unsigned big integers in decimal and do math with them
10
11# Internally the numbers are stored in an array with at least 1 element, no
027dc388 12# leading zero parts (except the first) and in base 1eX where X is determined
13# automatically at loading time to be the maximum possible value
0716bf9b 14
15# todo:
a87115f0 16# - fully remove funky $# stuff in div() (maybe - that code scares me...)
0716bf9b 17
18# USE_MUL: due to problems on certain os (os390, posix-bc) "* 1e-5" is used
ee15d750 19# instead of "/ 1e5" at some places, (marked with USE_MUL). Other platforms
20# BS2000, some Crays need USE_DIV instead.
bd05a461 21# The BEGIN block is used to determine which of the two variants gives the
22# correct result.
0716bf9b 23
990fb837 24# Beware of things like:
25# $i = $i * $y + $car; $car = int($i / $MBASE); $i = $i % $MBASE;
93c87d9d 26# This works on x86, but fails on ARM (SA1100, iPAQ) due to whoknows what
990fb837 27# reasons. So, use this instead (slower, but correct):
28# $i = $i * $y + $car; $car = int($i / $MBASE); $i -= $MBASE * $car;
29
0716bf9b 30##############################################################################
31# global constants, flags and accessory
9b924220 32
33# announce that we are compatible with MBI v1.70 and up
50109ad0 34sub api_version () { 2; }
0716bf9b 35
36# constants for easier life
233f7bc0 37my ($BASE,$BASE_LEN,$MBASE,$RBASE,$MAX_VAL,$BASE_LEN_SMALL);
394e6ffb 38my ($AND_BITS,$XOR_BITS,$OR_BITS);
39my ($AND_MASK,$XOR_MASK,$OR_MASK);
ee15d750 40
41sub _base_len
42 {
50109ad0 43 # Set/get the BASE_LEN and assorted other, connected values.
44 # Used only by the testsuite, the set variant is used only by the BEGIN
45 # block below:
394e6ffb 46 shift;
47
ee15d750 48 my $b = shift;
49 if (defined $b)
50 {
61f5c3f5 51 # find whether we can use mul or div or none in mul()/div()
52 # (in last case reduce BASE_LEN_SMALL)
53 $BASE_LEN_SMALL = $b+1;
54 my $caught = 0;
55 while (--$BASE_LEN_SMALL > 5)
394e6ffb 56 {
61f5c3f5 57 $MBASE = int("1e".$BASE_LEN_SMALL);
58 $RBASE = abs('1e-'.$BASE_LEN_SMALL); # see USE_MUL
394e6ffb 59 $caught = 0;
61f5c3f5 60 $caught += 1 if (int($MBASE * $RBASE) != 1); # should be 1
61 $caught += 2 if (int($MBASE / $MBASE) != 1); # should be 1
394e6ffb 62 last if $caught != 3;
63 }
61f5c3f5 64 # BASE_LEN is used for anything else than mul()/div()
65 $BASE_LEN = $BASE_LEN_SMALL;
66 $BASE_LEN = shift if (defined $_[0]); # one more arg?
ee15d750 67 $BASE = int("1e".$BASE_LEN);
61f5c3f5 68
61f5c3f5 69 $MBASE = int("1e".$BASE_LEN_SMALL);
70 $RBASE = abs('1e-'.$BASE_LEN_SMALL); # see USE_MUL
71 $MAX_VAL = $MBASE-1;
b68b7ab1 72
73 # avoid redefinitions
74
b05afeb3 75 undef &_mul;
76 undef &_div;
1ddff52a 77
50109ad0 78 # ($caught & 1) != 0 => cannot use MUL
79 # ($caught & 2) != 0 => cannot use DIV
990fb837 80 if ($caught == 2) # 2
ee15d750 81 {
990fb837 82 # must USE_MUL since we cannot use DIV
ee15d750 83 *{_mul} = \&_mul_use_mul;
84 *{_div} = \&_div_use_mul;
85 }
990fb837 86 else # 0 or 1
ee15d750 87 {
ee15d750 88 # can USE_DIV instead
89 *{_mul} = \&_mul_use_div;
90 *{_div} = \&_div_use_div;
91 }
92 }
61f5c3f5 93 return $BASE_LEN unless wantarray;
233f7bc0 94 return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN_SMALL, $MAX_VAL, $BASE);
ee15d750 95 }
574bacfe 96
03874afe 97sub _new
98 {
99 # (ref to string) return ref to num_array
100 # Convert a number from string format (without sign) to internal base
101 # 1ex format. Assumes normalized value as input.
102 my $il = length($_[1])-1;
103
104 # < BASE_LEN due len-1 above
105 return [ int($_[1]) ] if $il < $BASE_LEN; # shortcut for short numbers
106
107 # this leaves '00000' instead of int 0 and will be corrected after any op
108 [ reverse(unpack("a" . ($il % $BASE_LEN+1)
109 . ("a$BASE_LEN" x ($il / $BASE_LEN)), $_[1])) ];
110 }
111
574bacfe 112BEGIN
113 {
bd05a461 114 # from Daniel Pfeiffer: determine largest group of digits that is precisely
574bacfe 115 # multipliable with itself plus carry
dccbb853 116 # Test now changed to expect the proper pattern, not a result off by 1 or 2
117 my ($e, $num) = 3; # lowest value we will use is 3+1-1 = 3
bd05a461 118 do
119 {
120 $num = ('9' x ++$e) + 0;
394e6ffb 121 $num *= $num + 1.0;
394e6ffb 122 } while ("$num" =~ /9{$e}0{$e}/); # must be a certain pattern
123 $e--; # last test failed, so retract one step
124 # the limits below brush the problems with the test above under the rug:
125 # the test should be able to find the proper $e automatically
126 $e = 5 if $^O =~ /^uts/; # UTS get's some special treatment
127 $e = 5 if $^O =~ /^unicos/; # unicos is also problematic (6 seems to work
128 # there, but we play safe)
07d34614 129 $e = 5 if $] < 5.006; # cap, for older Perls
2e507a43 130 $e = 7 if $e > 7; # cap, for VMS, OS/390 and other 64 bit systems
131 # 8 fails inside random testsuite, so take 7
394e6ffb 132
03874afe 133 __PACKAGE__->_base_len($e); # set and store
394e6ffb 134
b68b7ab1 135 use integer;
394e6ffb 136 # find out how many bits _and, _or and _xor can take (old default = 16)
137 # I don't think anybody has yet 128 bit scalars, so let's play safe.
394e6ffb 138 local $^W = 0; # don't warn about 'nonportable number'
c38b2de2 139 $AND_BITS = 15; $XOR_BITS = 15; $OR_BITS = 15;
394e6ffb 140
141 # find max bits, we will not go higher than numberofbits that fit into $BASE
142 # to make _and etc simpler (and faster for smaller, slower for large numbers)
143 my $max = 16;
144 while (2 ** $max < $BASE) { $max++; }
1ddff52a 145 {
146 no integer;
147 $max = 16 if $] < 5.006; # older Perls might not take >16 too well
148 }
394e6ffb 149 my ($x,$y,$z);
150 do {
151 $AND_BITS++;
152 $x = oct('0b' . '1' x $AND_BITS); $y = $x & $x;
153 $z = (2 ** $AND_BITS) - 1;
154 } while ($AND_BITS < $max && $x == $z && $y == $x);
155 $AND_BITS --; # retreat one step
156 do {
157 $XOR_BITS++;
158 $x = oct('0b' . '1' x $XOR_BITS); $y = $x ^ 0;
159 $z = (2 ** $XOR_BITS) - 1;
160 } while ($XOR_BITS < $max && $x == $z && $y == $x);
161 $XOR_BITS --; # retreat one step
162 do {
163 $OR_BITS++;
164 $x = oct('0b' . '1' x $OR_BITS); $y = $x | $x;
165 $z = (2 ** $OR_BITS) - 1;
166 } while ($OR_BITS < $max && $x == $z && $y == $x);
167 $OR_BITS --; # retreat one step
168
9b924220 169 $AND_MASK = __PACKAGE__->_new( ( 2 ** $AND_BITS ));
170 $XOR_MASK = __PACKAGE__->_new( ( 2 ** $XOR_BITS ));
171 $OR_MASK = __PACKAGE__->_new( ( 2 ** $OR_BITS ));
50109ad0 172
173 # We can compute the approximate lenght no faster than the real length:
174 *_alen = \&_len;
394e6ffb 175 }
0716bf9b 176
03874afe 177###############################################################################
178
0716bf9b 179sub _zero
180 {
181 # create a zero
61f5c3f5 182 [ 0 ];
0716bf9b 183 }
184
185sub _one
186 {
187 # create a one
61f5c3f5 188 [ 1 ];
0716bf9b 189 }
190
027dc388 191sub _two
192 {
1ddff52a 193 # create a two (used internally for shifting)
61f5c3f5 194 [ 2 ];
027dc388 195 }
196
9b924220 197sub _ten
198 {
199 # create a 10 (used internally for shifting)
200 [ 10 ];
201 }
202
50109ad0 203sub _1ex
204 {
205 # create a 1Ex
206 my $rem = $_[1] % $BASE_LEN; # remainder
207 my $parts = $_[1] / $BASE_LEN; # parts
208
209 # 000000, 000000, 100
210 [ (0) x $parts, '1' . ('0' x $rem) ];
211 }
212
0716bf9b 213sub _copy
214 {
091c87b1 215 # make a true copy
61f5c3f5 216 [ @{$_[1]} ];
0716bf9b 217 }
218
bd05a461 219# catch and throw away
220sub import { }
221
0716bf9b 222##############################################################################
223# convert back to string and number
224
225sub _str
226 {
227 # (ref to BINT) return num_str
228 # Convert number from internal base 100000 format to string format.
229 # internal format is always normalized (no leading zeros, "-0" => "+0")
574bacfe 230 my $ar = $_[1];
61f5c3f5 231
b68b7ab1 232 my $l = scalar @$ar; # number of parts
233 if ($l < 1) # should not happen
234 {
235 require Carp;
236 Carp::croak("$_[1] has no elements");
237 }
61f5c3f5 238
b68b7ab1 239 my $ret = "";
0716bf9b 240 # handle first one different to strip leading zeros from it (there are no
241 # leading zero parts in internal representation)
61f5c3f5 242 $l --; $ret .= int($ar->[$l]); $l--;
0716bf9b 243 # Interestingly, the pre-padd method uses more time
091c87b1 244 # the old grep variant takes longer (14 vs. 10 sec)
574bacfe 245 my $z = '0' x ($BASE_LEN-1);
0716bf9b 246 while ($l >= 0)
247 {
574bacfe 248 $ret .= substr($z.$ar->[$l],-$BASE_LEN); # fastest way I could think of
0716bf9b 249 $l--;
250 }
9b924220 251 $ret;
0716bf9b 252 }
253
254sub _num
255 {
9b924220 256 # Make a number (scalar int/float) from a BigInt object
574bacfe 257 my $x = $_[1];
9b924220 258
259 return 0+$x->[0] if scalar @$x == 1; # below $BASE
0716bf9b 260 my $fac = 1;
261 my $num = 0;
262 foreach (@$x)
263 {
264 $num += $fac*$_; $fac *= $BASE;
265 }
61f5c3f5 266 $num;
0716bf9b 267 }
268
269##############################################################################
270# actual math code
271
272sub _add
273 {
274 # (ref to int_num_array, ref to int_num_array)
574bacfe 275 # routine to add two base 1eX numbers
0716bf9b 276 # stolen from Knuth Vol 2 Algorithm A pg 231
b22b3e31 277 # there are separate routines to add and sub as per Knuth pg 233
0716bf9b 278 # This routine clobbers up array x, but not y.
279
574bacfe 280 my ($c,$x,$y) = @_;
b3abae2a 281
282 return $x if (@$y == 1) && $y->[0] == 0; # $x + 0 => $x
283 if ((@$x == 1) && $x->[0] == 0) # 0 + $y => $y->copy
284 {
7b29e1e6 285 # twice as slow as $x = [ @$y ], but nec. to retain $x as ref :(
b3abae2a 286 @$x = @$y; return $x;
287 }
0716bf9b 288
289 # for each in Y, add Y to X and carry. If after that, something is left in
290 # X, foreach in X add carry to X and then return X, carry
091c87b1 291 # Trades one "$j++" for having to shift arrays
0716bf9b 292 my $i; my $car = 0; my $j = 0;
293 for $i (@$y)
294 {
e745a66c 295 $x->[$j] -= $BASE if $car = (($x->[$j] += $i + $car) >= $BASE) ? 1 : 0;
0716bf9b 296 $j++;
297 }
298 while ($car != 0)
299 {
300 $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; $j++;
301 }
61f5c3f5 302 $x;
e745a66c 303 }
304
305sub _inc
306 {
307 # (ref to int_num_array, ref to int_num_array)
091c87b1 308 # Add 1 to $x, modify $x in place
e745a66c 309 my ($c,$x) = @_;
310
311 for my $i (@$x)
312 {
313 return $x if (($i += 1) < $BASE); # early out
61f5c3f5 314 $i = 0; # overflow, next
e745a66c 315 }
ae161977 316 push @$x,1 if (($x->[-1] || 0) == 0); # last overflowed, so extend
61f5c3f5 317 $x;
e745a66c 318 }
319
320sub _dec
321 {
322 # (ref to int_num_array, ref to int_num_array)
091c87b1 323 # Sub 1 from $x, modify $x in place
e745a66c 324 my ($c,$x) = @_;
325
61f5c3f5 326 my $MAX = $BASE-1; # since MAX_VAL based on MBASE
e745a66c 327 for my $i (@$x)
328 {
329 last if (($i -= 1) >= 0); # early out
091c87b1 330 $i = $MAX; # underflow, next
e745a66c 331 }
091c87b1 332 pop @$x if $x->[-1] == 0 && @$x > 1; # last underflowed (but leave 0)
61f5c3f5 333 $x;
0716bf9b 334 }
335
336sub _sub
337 {
9393ace2 338 # (ref to int_num_array, ref to int_num_array, swap)
574bacfe 339 # subtract base 1eX numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
56b9c951 340 # subtract Y from X by modifying x in place
574bacfe 341 my ($c,$sx,$sy,$s) = @_;
0716bf9b 342
343 my $car = 0; my $i; my $j = 0;
344 if (!$s)
345 {
0716bf9b 346 for $i (@$sx)
347 {
348 last unless defined $sy->[$j] || $car;
0716bf9b 349 $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0); $j++;
0716bf9b 350 }
351 # might leave leading zeros, so fix that
394e6ffb 352 return __strip_zeros($sx);
0716bf9b 353 }
394e6ffb 354 for $i (@$sx)
0716bf9b 355 {
07d34614 356 # we can't do an early out if $x is < than $y, since we
56b9c951 357 # need to copy the high chunks from $y. Found by Bob Mathews.
358 #last unless defined $sy->[$j] || $car;
394e6ffb 359 $sy->[$j] += $BASE
360 if $car = (($sy->[$j] = $i-($sy->[$j]||0) - $car) < 0);
361 $j++;
0716bf9b 362 }
394e6ffb 363 # might leave leading zeros, so fix that
364 __strip_zeros($sy);
0716bf9b 365 }
366
ee15d750 367sub _mul_use_mul
0716bf9b 368 {
9393ace2 369 # (ref to int_num_array, ref to int_num_array)
0716bf9b 370 # multiply two numbers in internal representation
b22b3e31 371 # modifies first arg, second need not be different from first
574bacfe 372 my ($c,$xv,$yv) = @_;
dccbb853 373
990fb837 374 if (@$yv == 1)
b3abae2a 375 {
990fb837 376 # shortcut for two very short numbers (improved by Nathan Zook)
377 # works also if xv and yv are the same reference, and handles also $x == 0
378 if (@$xv == 1)
379 {
380 if (($xv->[0] *= $yv->[0]) >= $MBASE)
381 {
382 $xv->[0] = $xv->[0] - ($xv->[1] = int($xv->[0] * $RBASE)) * $MBASE;
383 };
384 return $xv;
385 }
386 # $x * 0 => 0
387 if ($yv->[0] == 0)
388 {
389 @$xv = (0);
390 return $xv;
391 }
392 # multiply a large number a by a single element one, so speed up
393 my $y = $yv->[0]; my $car = 0;
394 foreach my $i (@$xv)
395 {
396 $i = $i * $y + $car; $car = int($i * $RBASE); $i -= $car * $MBASE;
397 }
398 push @$xv, $car if $car != 0;
b3abae2a 399 return $xv;
400 }
990fb837 401 # shortcut for result $x == 0 => result = 0
402 return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) );
b3abae2a 403
0716bf9b 404 # since multiplying $x with $x fails, make copy in this case
d614cd8b 405 $yv = [@$xv] if $xv == $yv; # same references?
9393ace2 406
61f5c3f5 407 my @prod = (); my ($prod,$car,$cty,$xi,$yi);
408
0716bf9b 409 for $xi (@$xv)
410 {
411 $car = 0; $cty = 0;
574bacfe 412
413 # slow variant
414# for $yi (@$yv)
415# {
416# $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
417# $prod[$cty++] =
61f5c3f5 418# $prod - ($car = int($prod * RBASE)) * $MBASE; # see USE_MUL
574bacfe 419# }
420# $prod[$cty] += $car if $car; # need really to check for 0?
421# $xi = shift @prod;
422
423 # faster variant
424 # looping through this if $xi == 0 is silly - so optimize it away!
425 $xi = (shift @prod || 0), next if $xi == 0;
0716bf9b 426 for $yi (@$yv)
427 {
428 $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
574bacfe 429## this is actually a tad slower
430## $prod = $prod[$cty]; $prod += ($car + $xi * $yi); # no ||0 here
0716bf9b 431 $prod[$cty++] =
61f5c3f5 432 $prod - ($car = int($prod * $RBASE)) * $MBASE; # see USE_MUL
0716bf9b 433 }
434 $prod[$cty] += $car if $car; # need really to check for 0?
027dc388 435 $xi = shift @prod || 0; # || 0 makes v5.005_3 happy
0716bf9b 436 }
0716bf9b 437 push @$xv, @prod;
50109ad0 438 # can't have leading zeros
439# __strip_zeros($xv);
61f5c3f5 440 $xv;
0716bf9b 441 }
442
ee15d750 443sub _mul_use_div
444 {
9393ace2 445 # (ref to int_num_array, ref to int_num_array)
ee15d750 446 # multiply two numbers in internal representation
447 # modifies first arg, second need not be different from first
448 my ($c,$xv,$yv) = @_;
50109ad0 449
990fb837 450 if (@$yv == 1)
b3abae2a 451 {
990fb837 452 # shortcut for two small numbers, also handles $x == 0
453 if (@$xv == 1)
454 {
455 # shortcut for two very short numbers (improved by Nathan Zook)
456 # works also if xv and yv are the same reference, and handles also $x == 0
457 if (($xv->[0] *= $yv->[0]) >= $MBASE)
458 {
459 $xv->[0] =
460 $xv->[0] - ($xv->[1] = int($xv->[0] / $MBASE)) * $MBASE;
461 };
462 return $xv;
463 }
464 # $x * 0 => 0
465 if ($yv->[0] == 0)
466 {
467 @$xv = (0);
468 return $xv;
469 }
470 # multiply a large number a by a single element one, so speed up
471 my $y = $yv->[0]; my $car = 0;
472 foreach my $i (@$xv)
473 {
50109ad0 474 # old, slower code (before use integer;)
990fb837 475 $i = $i * $y + $car; $car = int($i / $MBASE); $i -= $car * $MBASE;
50109ad0 476 #$i = $i * $y + $car; $i -= ($car = $i / $MBASE) * $MBASE;
990fb837 477 }
478 push @$xv, $car if $car != 0;
b3abae2a 479 return $xv;
480 }
990fb837 481 # shortcut for result $x == 0 => result = 0
482 return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) );
b3abae2a 483
ee15d750 484 # since multiplying $x with $x fails, make copy in this case
d614cd8b 485 $yv = [@$xv] if $xv == $yv; # same references?
9393ace2 486
61f5c3f5 487 my @prod = (); my ($prod,$car,$cty,$xi,$yi);
ee15d750 488 for $xi (@$xv)
489 {
490 $car = 0; $cty = 0;
491 # looping through this if $xi == 0 is silly - so optimize it away!
492 $xi = (shift @prod || 0), next if $xi == 0;
493 for $yi (@$yv)
494 {
495 $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
50109ad0 496 $prod[$cty++] = $prod - ($car = int($prod / $MBASE)) * $MBASE;
ee15d750 497 }
498 $prod[$cty] += $car if $car; # need really to check for 0?
027dc388 499 $xi = shift @prod || 0; # || 0 makes v5.005_3 happy
ee15d750 500 }
501 push @$xv, @prod;
50109ad0 502 # can't have leading zeros
503# __strip_zeros($xv);
61f5c3f5 504 $xv;
ee15d750 505 }
506
507sub _div_use_mul
0716bf9b 508 {
b22b3e31 509 # ref to array, ref to array, modify first array and return remainder if
0716bf9b 510 # in list context
aef458a0 511
512 # see comments in _div_use_div() for more explanations
513
574bacfe 514 my ($c,$x,$yorg) = @_;
aef458a0 515
516 # the general div algorithmn here is about O(N*N) and thus quite slow, so
517 # we first check for some special cases and use shortcuts to handle them.
0716bf9b 518
aef458a0 519 # This works, because we store the numbers in a chunked format where each
520 # element contains 5..7 digits (depending on system).
521
522 # if both numbers have only one element:
61f5c3f5 523 if (@$x == 1 && @$yorg == 1)
524 {
13a12e00 525 # shortcut, $yorg and $x are two small numbers
61f5c3f5 526 if (wantarray)
527 {
528 my $r = [ $x->[0] % $yorg->[0] ];
529 $x->[0] = int($x->[0] / $yorg->[0]);
530 return ($x,$r);
531 }
532 else
533 {
534 $x->[0] = int($x->[0] / $yorg->[0]);
535 return $x;
536 }
537 }
aef458a0 538
539 # if x has more than one, but y has only one element:
28df3e88 540 if (@$yorg == 1)
541 {
542 my $rem;
543 $rem = _mod($c,[ @$x ],$yorg) if wantarray;
13a12e00 544
28df3e88 545 # shortcut, $y is < $BASE
546 my $j = scalar @$x; my $r = 0;
547 my $y = $yorg->[0]; my $b;
548 while ($j-- > 0)
549 {
550 $b = $r * $MBASE + $x->[$j];
551 $x->[$j] = int($b/$y);
552 $r = $b % $y;
553 }
554 pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero
555 return ($x,$rem) if wantarray;
556 return $x;
557 }
0716bf9b 558
aef458a0 559 # now x and y have more than one element
560
561 # check whether y has more elements than x, if yet, the result will be 0
562 if (@$yorg > @$x)
563 {
564 my $rem;
565 $rem = [@$x] if wantarray; # make copy
566 splice (@$x,1); # keep ref to original array
567 $x->[0] = 0; # set to 0
568 return ($x,$rem) if wantarray; # including remainder?
569 return $x; # only x, which is [0] now
570 }
571 # check whether the numbers have the same number of elements, in that case
572 # the result will fit into one element and can be computed efficiently
573 if (@$yorg == @$x)
574 {
575 my $rem;
576 # if $yorg has more digits than $x (it's leading element is longer than
577 # the one from $x), the result will also be 0:
578 if (length(int($yorg->[-1])) > length(int($x->[-1])))
579 {
580 $rem = [@$x] if wantarray; # make copy
581 splice (@$x,1); # keep ref to org array
582 $x->[0] = 0; # set to 0
583 return ($x,$rem) if wantarray; # including remainder?
584 return $x;
585 }
586 # now calculate $x / $yorg
587 if (length(int($yorg->[-1])) == length(int($x->[-1])))
588 {
b68b7ab1 589 # same length, so make full compare
590
aef458a0 591 my $a = 0; my $j = scalar @$x - 1;
592 # manual way (abort if unequal, good for early ne)
593 while ($j >= 0)
594 {
595 last if ($a = $x->[$j] - $yorg->[$j]); $j--;
596 }
597 # $a contains the result of the compare between X and Y
b68b7ab1 598 # a < 0: x < y, a == 0: x == y, a > 0: x > y
aef458a0 599 if ($a <= 0)
600 {
b68b7ab1 601 $rem = [ 0 ]; # a = 0 => x == y => rem 0
602 $rem = [@$x] if $a != 0; # a < 0 => x < y => rem = x
603 splice(@$x,1); # keep single element
604 $x->[0] = 0; # if $a < 0
605 $x->[0] = 1 if $a == 0; # $x == $y
7596a890 606 return ($x,$rem) if wantarray;
607 return $x;
aef458a0 608 }
b68b7ab1 609 # $x >= $y, so proceed normally
aef458a0 610 }
611 }
612
613 # all other cases:
614
d614cd8b 615 my $y = [ @$yorg ]; # always make copy to preserve
61f5c3f5 616
617 my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1,@d,$tmp,$q,$u2,$u1,$u0);
618
619 $car = $bar = $prd = 0;
620 if (($dd = int($MBASE/($y->[-1]+1))) != 1)
0716bf9b 621 {
622 for $xi (@$x)
623 {
624 $xi = $xi * $dd + $car;
61f5c3f5 625 $xi -= ($car = int($xi * $RBASE)) * $MBASE; # see USE_MUL
0716bf9b 626 }
627 push(@$x, $car); $car = 0;
628 for $yi (@$y)
629 {
630 $yi = $yi * $dd + $car;
61f5c3f5 631 $yi -= ($car = int($yi * $RBASE)) * $MBASE; # see USE_MUL
0716bf9b 632 }
633 }
634 else
635 {
636 push(@$x, 0);
637 }
638 @q = (); ($v2,$v1) = @$y[-2,-1];
639 $v2 = 0 unless $v2;
640 while ($#$x > $#$y)
641 {
642 ($u2,$u1,$u0) = @$x[-3..-1];
643 $u2 = 0 unless $u2;
644 #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n"
645 # if $v1 == 0;
aef458a0 646 $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$MBASE+$u1)/$v1));
61f5c3f5 647 --$q while ($v2*$q > ($u0*$MBASE+$u1-$q*$v1)*$MBASE+$u2);
0716bf9b 648 if ($q)
649 {
650 ($car, $bar) = (0,0);
651 for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
652 {
653 $prd = $q * $y->[$yi] + $car;
61f5c3f5 654 $prd -= ($car = int($prd * $RBASE)) * $MBASE; # see USE_MUL
655 $x->[$xi] += $MBASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0));
0716bf9b 656 }
657 if ($x->[-1] < $car + $bar)
658 {
659 $car = 0; --$q;
660 for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
661 {
61f5c3f5 662 $x->[$xi] -= $MBASE
aef458a0 663 if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $MBASE));
0716bf9b 664 }
665 }
666 }
aef458a0 667 pop(@$x);
668 unshift(@q, $q);
0716bf9b 669 }
670 if (wantarray)
671 {
672 @d = ();
673 if ($dd != 1)
674 {
675 $car = 0;
676 for $xi (reverse @$x)
677 {
61f5c3f5 678 $prd = $car * $MBASE + $xi;
0716bf9b 679 $car = $prd - ($tmp = int($prd / $dd)) * $dd; # see USE_MUL
680 unshift(@d, $tmp);
681 }
682 }
683 else
684 {
685 @d = @$x;
686 }
687 @$x = @q;
61f5c3f5 688 my $d = \@d;
990fb837 689 __strip_zeros($x);
690 __strip_zeros($d);
61f5c3f5 691 return ($x,$d);
0716bf9b 692 }
693 @$x = @q;
990fb837 694 __strip_zeros($x);
61f5c3f5 695 $x;
0716bf9b 696 }
697
ee15d750 698sub _div_use_div
699 {
700 # ref to array, ref to array, modify first array and return remainder if
701 # in list context
ee15d750 702 my ($c,$x,$yorg) = @_;
ee15d750 703
990fb837 704 # the general div algorithmn here is about O(N*N) and thus quite slow, so
705 # we first check for some special cases and use shortcuts to handle them.
706
707 # This works, because we store the numbers in a chunked format where each
708 # element contains 5..7 digits (depending on system).
709
710 # if both numbers have only one element:
61f5c3f5 711 if (@$x == 1 && @$yorg == 1)
712 {
13a12e00 713 # shortcut, $yorg and $x are two small numbers
61f5c3f5 714 if (wantarray)
715 {
716 my $r = [ $x->[0] % $yorg->[0] ];
717 $x->[0] = int($x->[0] / $yorg->[0]);
718 return ($x,$r);
719 }
720 else
721 {
722 $x->[0] = int($x->[0] / $yorg->[0]);
723 return $x;
724 }
725 }
990fb837 726 # if x has more than one, but y has only one element:
28df3e88 727 if (@$yorg == 1)
728 {
729 my $rem;
730 $rem = _mod($c,[ @$x ],$yorg) if wantarray;
731
732 # shortcut, $y is < $BASE
733 my $j = scalar @$x; my $r = 0;
734 my $y = $yorg->[0]; my $b;
735 while ($j-- > 0)
736 {
737 $b = $r * $MBASE + $x->[$j];
738 $x->[$j] = int($b/$y);
739 $r = $b % $y;
740 }
741 pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero
742 return ($x,$rem) if wantarray;
743 return $x;
744 }
990fb837 745 # now x and y have more than one element
ee15d750 746
990fb837 747 # check whether y has more elements than x, if yet, the result will be 0
748 if (@$yorg > @$x)
61f5c3f5 749 {
990fb837 750 my $rem;
751 $rem = [@$x] if wantarray; # make copy
752 splice (@$x,1); # keep ref to original array
753 $x->[0] = 0; # set to 0
754 return ($x,$rem) if wantarray; # including remainder?
aef458a0 755 return $x; # only x, which is [0] now
61f5c3f5 756 }
990fb837 757 # check whether the numbers have the same number of elements, in that case
758 # the result will fit into one element and can be computed efficiently
759 if (@$yorg == @$x)
760 {
761 my $rem;
762 # if $yorg has more digits than $x (it's leading element is longer than
763 # the one from $x), the result will also be 0:
764 if (length(int($yorg->[-1])) > length(int($x->[-1])))
765 {
766 $rem = [@$x] if wantarray; # make copy
767 splice (@$x,1); # keep ref to org array
768 $x->[0] = 0; # set to 0
769 return ($x,$rem) if wantarray; # including remainder?
770 return $x;
771 }
772 # now calculate $x / $yorg
091c87b1 773
990fb837 774 if (length(int($yorg->[-1])) == length(int($x->[-1])))
775 {
b68b7ab1 776 # same length, so make full compare
777
990fb837 778 my $a = 0; my $j = scalar @$x - 1;
779 # manual way (abort if unequal, good for early ne)
780 while ($j >= 0)
781 {
782 last if ($a = $x->[$j] - $yorg->[$j]); $j--;
783 }
aef458a0 784 # $a contains the result of the compare between X and Y
b68b7ab1 785 # a < 0: x < y, a == 0: x == y, a > 0: x > y
990fb837 786 if ($a <= 0)
787 {
b68b7ab1 788 $rem = [ 0 ]; # a = 0 => x == y => rem 0
789 $rem = [@$x] if $a != 0; # a < 0 => x < y => rem = x
aef458a0 790 splice(@$x,1); # keep single element
990fb837 791 $x->[0] = 0; # if $a < 0
b68b7ab1 792 $x->[0] = 1 if $a == 0; # $x == $y
7596a890 793 return ($x,$rem) if wantarray; # including remainder?
794 return $x;
990fb837 795 }
aef458a0 796 # $x >= $y, so proceed normally
b68b7ab1 797
990fb837 798 }
990fb837 799 }
800
801 # all other cases:
802
803 my $y = [ @$yorg ]; # always make copy to preserve
61f5c3f5 804
805 my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1,@d,$tmp,$q,$u2,$u1,$u0);
806
807 $car = $bar = $prd = 0;
808 if (($dd = int($MBASE/($y->[-1]+1))) != 1)
ee15d750 809 {
810 for $xi (@$x)
811 {
812 $xi = $xi * $dd + $car;
61f5c3f5 813 $xi -= ($car = int($xi / $MBASE)) * $MBASE;
ee15d750 814 }
815 push(@$x, $car); $car = 0;
816 for $yi (@$y)
817 {
818 $yi = $yi * $dd + $car;
61f5c3f5 819 $yi -= ($car = int($yi / $MBASE)) * $MBASE;
ee15d750 820 }
821 }
822 else
823 {
824 push(@$x, 0);
825 }
aef458a0 826
827 # @q will accumulate the final result, $q contains the current computed
828 # part of the final result
829
ee15d750 830 @q = (); ($v2,$v1) = @$y[-2,-1];
831 $v2 = 0 unless $v2;
832 while ($#$x > $#$y)
833 {
834 ($u2,$u1,$u0) = @$x[-3..-1];
835 $u2 = 0 unless $u2;
836 #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n"
837 # if $v1 == 0;
aef458a0 838 $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$MBASE+$u1)/$v1));
61f5c3f5 839 --$q while ($v2*$q > ($u0*$MBASE+$u1-$q*$v1)*$MBASE+$u2);
ee15d750 840 if ($q)
841 {
842 ($car, $bar) = (0,0);
843 for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
844 {
845 $prd = $q * $y->[$yi] + $car;
61f5c3f5 846 $prd -= ($car = int($prd / $MBASE)) * $MBASE;
847 $x->[$xi] += $MBASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0));
ee15d750 848 }
849 if ($x->[-1] < $car + $bar)
850 {
851 $car = 0; --$q;
852 for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
853 {
61f5c3f5 854 $x->[$xi] -= $MBASE
aef458a0 855 if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $MBASE));
ee15d750 856 }
857 }
858 }
61f5c3f5 859 pop(@$x); unshift(@q, $q);
ee15d750 860 }
861 if (wantarray)
862 {
863 @d = ();
864 if ($dd != 1)
865 {
866 $car = 0;
867 for $xi (reverse @$x)
868 {
61f5c3f5 869 $prd = $car * $MBASE + $xi;
ee15d750 870 $car = $prd - ($tmp = int($prd / $dd)) * $dd;
871 unshift(@d, $tmp);
872 }
873 }
874 else
875 {
876 @d = @$x;
877 }
878 @$x = @q;
61f5c3f5 879 my $d = \@d;
990fb837 880 __strip_zeros($x);
881 __strip_zeros($d);
61f5c3f5 882 return ($x,$d);
ee15d750 883 }
884 @$x = @q;
990fb837 885 __strip_zeros($x);
61f5c3f5 886 $x;
ee15d750 887 }
888
394e6ffb 889##############################################################################
890# testing
891
892sub _acmp
893 {
894 # internal absolute post-normalized compare (ignore signs)
895 # ref to array, ref to array, return <0, 0, >0
896 # arrays must have at least one entry; this is not checked for
394e6ffb 897 my ($c,$cx,$cy) = @_;
091c87b1 898
899 # shortcut for short numbers
900 return (($cx->[0] <=> $cy->[0]) <=> 0)
901 if scalar @$cx == scalar @$cy && scalar @$cx == 1;
394e6ffb 902
f9a08e12 903 # fast comp based on number of array elements (aka pseudo-length)
091c87b1 904 my $lxy = (scalar @$cx - scalar @$cy)
905 # or length of first element if same number of elements (aka difference 0)
906 ||
907 # need int() here because sometimes the last element is '00018' vs '18'
908 (length(int($cx->[-1])) - length(int($cy->[-1])));
394e6ffb 909 return -1 if $lxy < 0; # already differs, ret
910 return 1 if $lxy > 0; # ditto
56d9de68 911
394e6ffb 912 # manual way (abort if unequal, good for early ne)
091c87b1 913 my $a; my $j = scalar @$cx;
914 while (--$j >= 0)
9393ace2 915 {
091c87b1 916 last if ($a = $cx->[$j] - $cy->[$j]);
9393ace2 917 }
091c87b1 918 $a <=> 0;
394e6ffb 919 }
920
921sub _len
922 {
50109ad0 923 # compute number of digits in base 10
394e6ffb 924
925 # int() because add/sub sometimes leaves strings (like '00005') instead of
926 # '5' in this place, thus causing length() to report wrong length
927 my $cx = $_[1];
928
56d9de68 929 (@$cx-1)*$BASE_LEN+length(int($cx->[-1]));
394e6ffb 930 }
931
932sub _digit
933 {
934 # return the nth digit, negative values count backward
935 # zero is rightmost, so _digit(123,0) will give 3
936 my ($c,$x,$n) = @_;
937
938 my $len = _len('',$x);
939
940 $n = $len+$n if $n < 0; # -1 last, -2 second-to-last
941 $n = abs($n); # if negative was too big
942 $len--; $n = $len if $n > $len; # n to big?
943
944 my $elem = int($n / $BASE_LEN); # which array element
945 my $digit = $n % $BASE_LEN; # which digit in this element
52edfb59 946 $elem = '0' x $BASE_LEN . @$x[$elem]; # get element padded with 0's
56d9de68 947 substr($elem,-$digit-1,1);
394e6ffb 948 }
949
950sub _zeros
951 {
952 # return amount of trailing zeros in decimal
953 # check each array elem in _m for having 0 at end as long as elem == 0
954 # Upon finding a elem != 0, stop
955 my $x = $_[1];
9b924220 956
957 return 0 if scalar @$x == 1 && $x->[0] == 0;
958
394e6ffb 959 my $zeros = 0; my $elem;
960 foreach my $e (@$x)
961 {
962 if ($e != 0)
963 {
964 $elem = "$e"; # preserve x
965 $elem =~ s/.*?(0*$)/$1/; # strip anything not zero
966 $zeros *= $BASE_LEN; # elems * 5
61f5c3f5 967 $zeros += length($elem); # count trailing zeros
394e6ffb 968 last; # early out
969 }
970 $zeros ++; # real else branch: 50% slower!
971 }
61f5c3f5 972 $zeros;
394e6ffb 973 }
974
975##############################################################################
976# _is_* routines
977
978sub _is_zero
979 {
9b924220 980 # return true if arg is zero
981 (((scalar @{$_[1]} == 1) && ($_[1]->[0] == 0))) <=> 0;
394e6ffb 982 }
983
984sub _is_even
985 {
9b924220 986 # return true if arg is even
987 (!($_[1]->[0] & 1)) <=> 0;
394e6ffb 988 }
989
990sub _is_odd
991 {
9b924220 992 # return true if arg is even
993 (($_[1]->[0] & 1)) <=> 0;
394e6ffb 994 }
995
996sub _is_one
997 {
9b924220 998 # return true if arg is one
999 (scalar @{$_[1]} == 1) && ($_[1]->[0] == 1) <=> 0;
1000 }
1001
1002sub _is_two
1003 {
1004 # return true if arg is two
1005 (scalar @{$_[1]} == 1) && ($_[1]->[0] == 2) <=> 0;
1006 }
61f5c3f5 1007
9b924220 1008sub _is_ten
1009 {
1010 # return true if arg is ten
1011 (scalar @{$_[1]} == 1) && ($_[1]->[0] == 10) <=> 0;
394e6ffb 1012 }
1013
1014sub __strip_zeros
1015 {
1016 # internal normalization function that strips leading zeros from the array
1017 # args: ref to array
1018 my $s = shift;
1019
1020 my $cnt = scalar @$s; # get count of parts
1021 my $i = $cnt-1;
1022 push @$s,0 if $i < 0; # div might return empty results, so fix it
1023
61f5c3f5 1024 return $s if @$s == 1; # early out
1025
394e6ffb 1026 #print "strip: cnt $cnt i $i\n";
1027 # '0', '3', '4', '0', '0',
1028 # 0 1 2 3 4
1029 # cnt = 5, i = 4
1030 # i = 4
1031 # i = 3
1032 # => fcnt = cnt - i (5-2 => 3, cnt => 5-1 = 4, throw away from 4th pos)
1033 # >= 1: skip first part (this can be zero)
1034 while ($i > 0) { last if $s->[$i] != 0; $i--; }
1035 $i++; splice @$s,$i if ($i < $cnt); # $i cant be 0
1036 $s;
1037 }
1038
1039###############################################################################
3a427a11 1040# check routine to test internal state for corruptions
394e6ffb 1041
1042sub _check
1043 {
1044 # used by the test suite
1045 my $x = $_[1];
1046
1047 return "$x is not a reference" if !ref($x);
1048
1049 # are all parts are valid?
1050 my $i = 0; my $j = scalar @$x; my ($e,$try);
1051 while ($i < $j)
1052 {
1053 $e = $x->[$i]; $e = 'undef' unless defined $e;
1054 $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e)";
1055 last if $e !~ /^[+]?[0-9]+$/;
1056 $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (stringify)";
1057 last if "$e" !~ /^[+]?[0-9]+$/;
1058 $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (cat-stringify)";
1059 last if '' . "$e" !~ /^[+]?[0-9]+$/;
1060 $try = ' < 0 || >= $BASE; '."($x, $e)";
1061 last if $e <0 || $e >= $BASE;
1062 # this test is disabled, since new/bnorm and certain ops (like early out
1063 # in add/sub) are allowed/expected to leave '00000' in some elements
1064 #$try = '=~ /^00+/; '."($x, $e)";
1065 #last if $e =~ /^00+/;
1066 $i++;
1067 }
1068 return "Illegal part '$e' at pos $i (tested: $try)" if $i < $j;
3a427a11 1069 0;
394e6ffb 1070 }
1071
1072
1073###############################################################################
394e6ffb 1074
dccbb853 1075sub _mod
1076 {
1077 # if possible, use mod shortcut
1078 my ($c,$x,$yo) = @_;
1079
1080 # slow way since $y to big
1081 if (scalar @$yo > 1)
1082 {
1083 my ($xo,$rem) = _div($c,$x,$yo);
1084 return $rem;
1085 }
aef458a0 1086
dccbb853 1087 my $y = $yo->[0];
027dc388 1088 # both are single element arrays
dccbb853 1089 if (scalar @$x == 1)
1090 {
1091 $x->[0] %= $y;
1092 return $x;
1093 }
1094
aef458a0 1095 # @y is a single element, but @x has more than one element
dccbb853 1096 my $b = $BASE % $y;
1097 if ($b == 0)
1098 {
1099 # when BASE % Y == 0 then (B * BASE) % Y == 0
1100 # (B * BASE) % $y + A % Y => A % Y
1101 # so need to consider only last element: O(1)
1102 $x->[0] %= $y;
1103 }
027dc388 1104 elsif ($b == 1)
1105 {
3a427a11 1106 # else need to go through all elements: O(N), but loop is a bit simplified
027dc388 1107 my $r = 0;
1108 foreach (@$x)
1109 {
28df3e88 1110 $r = ($r + $_) % $y; # not much faster, but heh...
1111 #$r += $_ % $y; $r %= $y;
027dc388 1112 }
1113 $r = 0 if $r == $y;
1114 $x->[0] = $r;
1115 }
dccbb853 1116 else
1117 {
3a427a11 1118 # else need to go through all elements: O(N)
027dc388 1119 my $r = 0; my $bm = 1;
1120 foreach (@$x)
1121 {
28df3e88 1122 $r = ($_ * $bm + $r) % $y;
1123 $bm = ($bm * $b) % $y;
1124
1125 #$r += ($_ % $y) * $bm;
1126 #$bm *= $b;
1127 #$bm %= $y;
1128 #$r %= $y;
027dc388 1129 }
1130 $r = 0 if $r == $y;
1131 $x->[0] = $r;
dccbb853 1132 }
091c87b1 1133 splice (@$x,1); # keep one element of $x
61f5c3f5 1134 $x;
dccbb853 1135 }
1136
0716bf9b 1137##############################################################################
574bacfe 1138# shifts
1139
1140sub _rsft
1141 {
1142 my ($c,$x,$y,$n) = @_;
1143
1144 if ($n != 10)
1145 {
9b924220 1146 $n = _new($c,$n); return _div($c,$x, _pow($c,$n,$y));
61f5c3f5 1147 }
1148
1149 # shortcut (faster) for shifting by 10)
1150 # multiples of $BASE_LEN
1151 my $dst = 0; # destination
1152 my $src = _num($c,$y); # as normal int
56d9de68 1153 my $xlen = (@$x-1)*$BASE_LEN+length(int($x->[-1])); # len of x in digits
90d1b129 1154 if ($src >= $xlen or ($src == $xlen and ! defined $x->[1]))
56d9de68 1155 {
1156 # 12345 67890 shifted right by more than 10 digits => 0
1157 splice (@$x,1); # leave only one element
1158 $x->[0] = 0; # set to zero
1159 return $x;
1160 }
61f5c3f5 1161 my $rem = $src % $BASE_LEN; # remainder to shift
1162 $src = int($src / $BASE_LEN); # source
1163 if ($rem == 0)
1164 {
1165 splice (@$x,0,$src); # even faster, 38.4 => 39.3
574bacfe 1166 }
1167 else
1168 {
61f5c3f5 1169 my $len = scalar @$x - $src; # elems to go
1170 my $vd; my $z = '0'x $BASE_LEN;
1171 $x->[scalar @$x] = 0; # avoid || 0 test inside loop
1172 while ($dst < $len)
574bacfe 1173 {
61f5c3f5 1174 $vd = $z.$x->[$src];
1175 $vd = substr($vd,-$BASE_LEN,$BASE_LEN-$rem);
1176 $src++;
1177 $vd = substr($z.$x->[$src],-$rem,$rem) . $vd;
1178 $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN;
1179 $x->[$dst] = int($vd);
1180 $dst++;
574bacfe 1181 }
61f5c3f5 1182 splice (@$x,$dst) if $dst > 0; # kill left-over array elems
56b9c951 1183 pop @$x if $x->[-1] == 0 && @$x > 1; # kill last element if 0
61f5c3f5 1184 } # else rem == 0
574bacfe 1185 $x;
1186 }
1187
1188sub _lsft
1189 {
1190 my ($c,$x,$y,$n) = @_;
1191
1192 if ($n != 10)
1193 {
9b924220 1194 $n = _new($c,$n); return _mul($c,$x, _pow($c,$n,$y));
574bacfe 1195 }
61f5c3f5 1196
1197 # shortcut (faster) for shifting by 10) since we are in base 10eX
1198 # multiples of $BASE_LEN:
1199 my $src = scalar @$x; # source
1200 my $len = _num($c,$y); # shift-len as normal int
1201 my $rem = $len % $BASE_LEN; # remainder to shift
1202 my $dst = $src + int($len/$BASE_LEN); # destination
1203 my $vd; # further speedup
1204 $x->[$src] = 0; # avoid first ||0 for speed
1205 my $z = '0' x $BASE_LEN;
1206 while ($src >= 0)
574bacfe 1207 {
61f5c3f5 1208 $vd = $x->[$src]; $vd = $z.$vd;
1209 $vd = substr($vd,-$BASE_LEN+$rem,$BASE_LEN-$rem);
1210 $vd .= $src > 0 ? substr($z.$x->[$src-1],-$BASE_LEN,$rem) : '0' x $rem;
1211 $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN;
1212 $x->[$dst] = int($vd);
1213 $dst--; $src--;
574bacfe 1214 }
61f5c3f5 1215 # set lowest parts to 0
1216 while ($dst >= 0) { $x->[$dst--] = 0; }
1217 # fix spurios last zero element
1218 splice @$x,-1 if $x->[-1] == 0;
574bacfe 1219 $x;
1220 }
1221
027dc388 1222sub _pow
1223 {
1224 # power of $x to $y
1225 # ref to array, ref to array, return ref to array
1226 my ($c,$cx,$cy) = @_;
1227
b282a552 1228 if (scalar @$cy == 1 && $cy->[0] == 0)
1229 {
1230 splice (@$cx,1); $cx->[0] = 1; # y == 0 => x => 1
1231 return $cx;
1232 }
1233 if ((scalar @$cx == 1 && $cx->[0] == 1) || # x == 1
1234 (scalar @$cy == 1 && $cy->[0] == 1)) # or y == 1
1235 {
1236 return $cx;
1237 }
1238 if (scalar @$cx == 1 && $cx->[0] == 0)
1239 {
1240 splice (@$cx,1); $cx->[0] = 0; # 0 ** y => 0 (if not y <= 0)
1241 return $cx;
1242 }
1243
027dc388 1244 my $pow2 = _one();
1ddff52a 1245
9b924220 1246 my $y_bin = _as_bin($c,$cy); $y_bin =~ s/^0b//;
1ddff52a 1247 my $len = length($y_bin);
1248 while (--$len > 0)
027dc388 1249 {
1ddff52a 1250 _mul($c,$pow2,$cx) if substr($y_bin,$len,1) eq '1'; # is odd?
027dc388 1251 _mul($c,$cx,$cx);
1252 }
1ddff52a 1253
1254 _mul($c,$cx,$pow2);
61f5c3f5 1255 $cx;
027dc388 1256 }
1257
50109ad0 1258sub _nok
1259 {
1260 # n over k
1261 # ref to array, return ref to array
1262 my ($c,$n,$k) = @_;
1263
1264 # ( 7 ) 7! 7*6*5 * 4*3*2*1 7 * 6 * 5
1265 # ( - ) = --------- = --------------- = ---------
1266 # ( 3 ) 3! (7-3)! 3*2*1 * 4*3*2*1 3 * 2 * 1
1267
1268 # compute n - k + 2 (so we start with 5 in the example above)
1269 my $x = _copy($c,$n);
1270
1271 _sub($c,$n,$k);
1272 if (!_is_one($c,$n))
1273 {
1274 _inc($c,$n);
1275 my $f = _copy($c,$n); _inc($c,$f); # n = 5, f = 6, d = 2
1276 my $d = _two($c);
1277 while (_acmp($c,$f,$x) <= 0) # f < n ?
1278 {
1279 # n = (n * f / d) == 5 * 6 / 2 => n == 3
1280 $n = _mul($c,$n,$f); $n = _div($c,$n,$d);
1281 # f = 7, d = 3
1282 _inc($c,$f); _inc($c,$d);
1283 }
1284 }
1285 else
1286 {
1287 # keep ref to $n and set it to 1
1288 splice (@$n,1); $n->[0] = 1;
1289 }
1290 $n;
1291 }
1292
1293my @factorials = (
1294 1,
1295 1,
1296 2,
1297 2*3,
1298 2*3*4,
1299 2*3*4*5,
1300 2*3*4*5*6,
1301 2*3*4*5*6*7,
1302);
1303
b3abae2a 1304sub _fac
1305 {
1306 # factorial of $x
1307 # ref to array, return ref to array
1308 my ($c,$cx) = @_;
1309
50109ad0 1310 if ((@$cx == 1) && ($cx->[0] <= 7))
b3abae2a 1311 {
50109ad0 1312 $cx->[0] = $factorials[$cx->[0]]; # 0 => 1, 1 => 1, 2 => 2 etc.
b3abae2a 1313 return $cx;
1314 }
1315
50109ad0 1316 if ((@$cx == 1) && # we do this only if $x >= 12 and $x <= 7000
1317 ($cx->[0] >= 12 && $cx->[0] < 7000))
1318 {
1319
1320 # Calculate (k-j) * (k-j+1) ... k .. (k+j-1) * (k + j)
1321 # See http://blogten.blogspot.com/2007/01/calculating-n.html
1322 # The above series can be expressed as factors:
1323 # k * k - (j - i) * 2
1324 # We cache k*k, and calculate (j * j) as the sum of the first j odd integers
1325
1326 # This will not work when N exceeds the storage of a Perl scalar, however,
1327 # in this case the algorithm would be way to slow to terminate, anyway.
1328
1329 # As soon as the last element of $cx is 0, we split it up and remember
1330 # how many zeors we got so far. The reason is that n! will accumulate
1331 # zeros at the end rather fast.
1332 my $zero_elements = 0;
1333
1334 # If n is even, set n = n -1
1335 my $k = _num($c,$cx); my $even = 1;
1336 if (($k & 1) == 0)
1337 {
1338 $even = $k; $k --;
1339 }
1340 # set k to the center point
1341 $k = ($k + 1) / 2;
1342# print "k $k even: $even\n";
1343 # now calculate k * k
1344 my $k2 = $k * $k;
1345 my $odd = 1; my $sum = 1;
1346 my $i = $k - 1;
1347 # keep reference to x
1348 my $new_x = _new($c, $k * $even);
1349 @$cx = @$new_x;
1350 if ($cx->[0] == 0)
1351 {
1352 $zero_elements ++; shift @$cx;
1353 }
1354# print STDERR "x = ", _str($c,$cx),"\n";
1355 my $BASE2 = int(sqrt($BASE))-1;
1356 my $j = 1;
1357 while ($j <= $i)
1358 {
1359 my $m = ($k2 - $sum); $odd += 2; $sum += $odd; $j++;
1360 while ($j <= $i && ($m < $BASE2) && (($k2 - $sum) < $BASE2))
1361 {
1362 $m *= ($k2 - $sum);
1363 $odd += 2; $sum += $odd; $j++;
1364# print STDERR "\n k2 $k2 m $m sum $sum odd $odd\n"; sleep(1);
1365 }
1366 if ($m < $BASE)
1367 {
1368 _mul($c,$cx,[$m]);
1369 }
1370 else
1371 {
1372 _mul($c,$cx,$c->_new($m));
1373 }
1374 if ($cx->[0] == 0)
1375 {
1376 $zero_elements ++; shift @$cx;
1377 }
1378# print STDERR "Calculate $k2 - $sum = $m (x = ", _str($c,$cx),")\n";
1379 }
1380 # multiply in the zeros again
1381 unshift @$cx, (0) x $zero_elements;
1382 return $cx;
1383 }
1384
b3abae2a 1385 # go forward until $base is exceeded
091c87b1 1386 # limit is either $x steps (steps == 100 means a result always too high) or
1387 # $base.
b3abae2a 1388 my $steps = 100; $steps = $cx->[0] if @$cx == 1;
091c87b1 1389 my $r = 2; my $cf = 3; my $step = 2; my $last = $r;
1390 while ($r*$cf < $BASE && $step < $steps)
b3abae2a 1391 {
1392 $last = $r; $r *= $cf++; $step++;
1393 }
091c87b1 1394 if ((@$cx == 1) && $step == $cx->[0])
b3abae2a 1395 {
091c87b1 1396 # completely done, so keep reference to $x and return
1397 $cx->[0] = $r;
b3abae2a 1398 return $cx;
1399 }
091c87b1 1400
990fb837 1401 # now we must do the left over steps
091c87b1 1402 my $n; # steps still to do
1403 if (scalar @$cx == 1)
1404 {
1405 $n = $cx->[0];
1406 }
1407 else
1408 {
1409 $n = _copy($c,$cx);
1410 }
b3abae2a 1411
50109ad0 1412 # Set $cx to the last result below $BASE (but keep ref to $x)
1413 $cx->[0] = $last; splice (@$cx,1);
1414 # As soon as the last element of $cx is 0, we split it up and remember
1415 # how many zeors we got so far. The reason is that n! will accumulate
1416 # zeros at the end rather fast.
990fb837 1417 my $zero_elements = 0;
091c87b1 1418
1419 # do left-over steps fit into a scalar?
1420 if (ref $n eq 'ARRAY')
b3abae2a 1421 {
091c87b1 1422 # No, so use slower inc() & cmp()
50109ad0 1423 # ($n is at least $BASE here)
1424 my $base_2 = int(sqrt($BASE)) - 1;
1425 #print STDERR "base_2: $base_2\n";
1426 while ($step < $base_2)
1427 {
1428 if ($cx->[0] == 0)
1429 {
1430 $zero_elements ++; shift @$cx;
1431 }
1432 my $b = $step * ($step + 1); $step += 2;
1433 _mul($c,$cx,[$b]);
1434 }
091c87b1 1435 $step = [$step];
50109ad0 1436 while (_acmp($c,$step,$n) <= 0)
990fb837 1437 {
1438 if ($cx->[0] == 0)
1439 {
1440 $zero_elements ++; shift @$cx;
1441 }
091c87b1 1442 _mul($c,$cx,$step); _inc($c,$step);
990fb837 1443 }
990fb837 1444 }
091c87b1 1445 else
990fb837 1446 {
091c87b1 1447 # Yes, so we can speed it up slightly
50109ad0 1448
1449# print "# left over steps $n\n";
1450
1451 my $base_4 = int(sqrt(sqrt($BASE))) - 2;
1452 #print STDERR "base_4: $base_4\n";
1453 my $n4 = $n - 4;
1454 while ($step < $n4 && $step < $base_4)
990fb837 1455 {
091c87b1 1456 if ($cx->[0] == 0)
1457 {
1458 $zero_elements ++; shift @$cx;
1459 }
50109ad0 1460 my $b = $step * ($step + 1); $step += 2; $b *= $step * ($step + 1); $step += 2;
1461 _mul($c,$cx,[$b]);
1462 }
1463 my $base_2 = int(sqrt($BASE)) - 1;
1464 my $n2 = $n - 2;
1465 #print STDERR "base_2: $base_2\n";
1466 while ($step < $n2 && $step < $base_2)
1467 {
1468 if ($cx->[0] == 0)
1469 {
1470 $zero_elements ++; shift @$cx;
1471 }
1472 my $b = $step * ($step + 1); $step += 2;
1473 _mul($c,$cx,[$b]);
1474 }
1475 # do what's left over
1476 while ($step <= $n)
1477 {
091c87b1 1478 _mul($c,$cx,[$step]); $step++;
50109ad0 1479 if ($cx->[0] == 0)
1480 {
1481 $zero_elements ++; shift @$cx;
1482 }
990fb837 1483 }
990fb837 1484 }
1485 # multiply in the zeros again
50109ad0 1486 unshift @$cx, (0) x $zero_elements;
091c87b1 1487 $cx; # return result
1488 }
1489
9b924220 1490#############################################################################
1491
091c87b1 1492sub _log_int
1493 {
1494 # calculate integer log of $x to base $base
1495 # ref to array, ref to array - return ref to array
1496 my ($c,$x,$base) = @_;
1497
1498 # X == 0 => NaN
1499 return if (scalar @$x == 1 && $x->[0] == 0);
1500 # BASE 0 or 1 => NaN
1501 return if (scalar @$base == 1 && $base->[0] < 2);
b282a552 1502 my $cmp = _acmp($c,$x,$base); # X == BASE => 1
091c87b1 1503 if ($cmp == 0)
1504 {
1505 splice (@$x,1); $x->[0] = 1;
8df1e0a2 1506 return ($x,1)
091c87b1 1507 }
1508 # X < BASE
1509 if ($cmp < 0)
1510 {
1511 splice (@$x,1); $x->[0] = 0;
8df1e0a2 1512 return ($x,undef);
091c87b1 1513 }
1514
1515 # this trial multiplication is very fast, even for large counts (like for
1516 # 2 ** 1024, since this still requires only 1024 very fast steps
1517 # (multiplication of a large number by a very small number is very fast))
1518 my $x_org = _copy($c,$x); # preserve x
8df1e0a2 1519 splice(@$x,1); $x->[0] = 1; # keep ref to $x
1520
b282a552 1521 my $trial = _copy($c,$base);
1522
1523 # XXX TODO this only works if $base has only one element
1524 if (scalar @$base == 1)
1525 {
1526 # compute int ( length_in_base_10(X) / ( log(base) / log(10) ) )
1527 my $len = _len($c,$x_org);
1528 my $res = int($len / (log($base->[0]) / log(10))) || 1; # avoid $res == 0
1529
1530 $x->[0] = $res;
1531 $trial = _pow ($c, _copy($c, $base), $x);
1532 my $a = _acmp($x,$trial,$x_org);
1533 return ($x,1) if $a == 0;
3a427a11 1534 # we now know that $res is too small
b282a552 1535 if ($res < 0)
1536 {
1537 _mul($c,$trial,$base); _add($c, $x, [1]);
1538 }
1539 else
1540 {
1541 # or too big
1542 _div($c,$trial,$base); _sub($c, $x, [1]);
1543 }
1544 # did we now get the right result?
1545 $a = _acmp($x,$trial,$x_org);
1546 return ($x,1) if $a == 0; # yes, exactly
1547 # still too big
1548 if ($a > 0)
1549 {
1550 _div($c,$trial,$base); _sub($c, $x, [1]);
1551 }
1552 }
1553
8df1e0a2 1554 # simple loop that increments $x by two in each step, possible overstepping
1555 # the real result by one
091c87b1 1556
b282a552 1557 my $a;
8df1e0a2 1558 my $base_mul = _mul($c, _copy($c,$base), $base);
1559
9b924220 1560 while (($a = _acmp($c,$trial,$x_org)) < 0)
091c87b1 1561 {
8df1e0a2 1562 _mul($c,$trial,$base_mul); _add($c, $x, [2]);
091c87b1 1563 }
8df1e0a2 1564
1565 my $exact = 1;
1566 if ($a > 0)
091c87b1 1567 {
8df1e0a2 1568 # overstepped the result
1569 _dec($c, $x);
1570 _div($c,$trial,$base);
9b924220 1571 $a = _acmp($c,$trial,$x_org);
8df1e0a2 1572 if ($a > 0)
091c87b1 1573 {
8df1e0a2 1574 _dec($c, $x);
091c87b1 1575 }
8df1e0a2 1576 $exact = 0 if $a != 0;
091c87b1 1577 }
1578
8df1e0a2 1579 ($x,$exact); # return result
b3abae2a 1580 }
1581
56d9de68 1582# for debugging:
1583 use constant DEBUG => 0;
1584 my $steps = 0;
1585 sub steps { $steps };
b3abae2a 1586
1587sub _sqrt
0716bf9b 1588 {
56d9de68 1589 # square-root of $x in place
990fb837 1590 # Compute a guess of the result (by rule of thumb), then improve it via
56d9de68 1591 # Newton's method.
394e6ffb 1592 my ($c,$x) = @_;
0716bf9b 1593
394e6ffb 1594 if (scalar @$x == 1)
1595 {
50109ad0 1596 # fits into one Perl scalar, so result can be computed directly
394e6ffb 1597 $x->[0] = int(sqrt($x->[0]));
1598 return $x;
1599 }
1600 my $y = _copy($c,$x);
b3abae2a 1601 # hopefully _len/2 is < $BASE, the -1 is to always undershot the guess
1602 # since our guess will "grow"
1603 my $l = int((_len($c,$x)-1) / 2);
1604
56d9de68 1605 my $lastelem = $x->[-1]; # for guess
b3abae2a 1606 my $elems = scalar @$x - 1;
1607 # not enough digits, but could have more?
56d9de68 1608 if ((length($lastelem) <= 3) && ($elems > 1))
b3abae2a 1609 {
1610 # right-align with zero pad
1611 my $len = length($lastelem) & 1;
1612 print "$lastelem => " if DEBUG;
1613 $lastelem .= substr($x->[-2] . '0' x $BASE_LEN,0,$BASE_LEN);
1614 # former odd => make odd again, or former even to even again
56d9de68 1615 $lastelem = $lastelem / 10 if (length($lastelem) & 1) != $len;
b3abae2a 1616 print "$lastelem\n" if DEBUG;
1617 }
0716bf9b 1618
61f5c3f5 1619 # construct $x (instead of _lsft($c,$x,$l,10)
1620 my $r = $l % $BASE_LEN; # 10000 00000 00000 00000 ($BASE_LEN=5)
1621 $l = int($l / $BASE_LEN);
b3abae2a 1622 print "l = $l " if DEBUG;
56d9de68 1623
1624 splice @$x,$l; # keep ref($x), but modify it
1625
b3abae2a 1626 # we make the first part of the guess not '1000...0' but int(sqrt($lastelem))
1627 # that gives us:
56d9de68 1628 # 14400 00000 => sqrt(14400) => guess first digits to be 120
1629 # 144000 000000 => sqrt(144000) => guess 379
b3abae2a 1630
b3abae2a 1631 print "$lastelem (elems $elems) => " if DEBUG;
1632 $lastelem = $lastelem / 10 if ($elems & 1 == 1); # odd or even?
1633 my $g = sqrt($lastelem); $g =~ s/\.//; # 2.345 => 2345
1634 $r -= 1 if $elems & 1 == 0; # 70 => 7
1635
1636 # padd with zeros if result is too short
1637 $x->[$l--] = int(substr($g . '0' x $r,0,$r+1));
1638 print "now ",$x->[-1] if DEBUG;
1639 print " would have been ", int('1' . '0' x $r),"\n" if DEBUG;
56d9de68 1640
b3abae2a 1641 # If @$x > 1, we could compute the second elem of the guess, too, to create
56d9de68 1642 # an even better guess. Not implemented yet. Does it improve performance?
b3abae2a 1643 $x->[$l--] = 0 while ($l >= 0); # all other digits of guess are zero
56d9de68 1644
9b924220 1645 print "start x= ",_str($c,$x),"\n" if DEBUG;
394e6ffb 1646 my $two = _two();
1647 my $last = _zero();
1648 my $lastlast = _zero();
b3abae2a 1649 $steps = 0 if DEBUG;
394e6ffb 1650 while (_acmp($c,$last,$x) != 0 && _acmp($c,$lastlast,$x) != 0)
1651 {
b3abae2a 1652 $steps++ if DEBUG;
394e6ffb 1653 $lastlast = _copy($c,$last);
1654 $last = _copy($c,$x);
1655 _add($c,$x, _div($c,_copy($c,$y),$x));
1656 _div($c,$x, $two );
9b924220 1657 print " x= ",_str($c,$x),"\n" if DEBUG;
394e6ffb 1658 }
b3abae2a 1659 print "\nsteps in sqrt: $steps, " if DEBUG;
394e6ffb 1660 _dec($c,$x) if _acmp($c,$y,_mul($c,_copy($c,$x),$x)) < 0; # overshot?
b3abae2a 1661 print " final ",$x->[-1],"\n" if DEBUG;
394e6ffb 1662 $x;
0716bf9b 1663 }
1664
990fb837 1665sub _root
1666 {
1667 # take n'th root of $x in place (n >= 3)
990fb837 1668 my ($c,$x,$n) = @_;
1669
1670 if (scalar @$x == 1)
1671 {
1672 if (scalar @$n > 1)
1673 {
1674 # result will always be smaller than 2 so trunc to 1 at once
1675 $x->[0] = 1;
1676 }
1677 else
1678 {
50109ad0 1679 # fits into one Perl scalar, so result can be computed directly
091c87b1 1680 # cannot use int() here, because it rounds wrongly (try
1681 # (81 ** 3) ** (1/3) to see what I mean)
1682 #$x->[0] = int( $x->[0] ** (1 / $n->[0]) );
1683 # round to 8 digits, then truncate result to integer
1684 $x->[0] = int ( sprintf ("%.8f", $x->[0] ** (1 / $n->[0]) ) );
990fb837 1685 }
1686 return $x;
1687 }
1688
3a427a11 1689 # we know now that X is more than one element long
1690
c38b2de2 1691 # if $n is a power of two, we can repeatedly take sqrt($X) and find the
1692 # proper result, because sqrt(sqrt($x)) == root($x,4)
1693 my $b = _as_bin($c,$n);
9b924220 1694 if ($b =~ /0b1(0+)$/)
c38b2de2 1695 {
1696 my $count = CORE::length($1); # 0b100 => len('00') => 2
1697 my $cnt = $count; # counter for loop
1698 unshift (@$x, 0); # add one element, together with one
1699 # more below in the loop this makes 2
1700 while ($cnt-- > 0)
1701 {
1702 # 'inflate' $X by adding one element, basically computing
1703 # $x * $BASE * $BASE. This gives us more $BASE_LEN digits for result
1704 # since len(sqrt($X)) approx == len($x) / 2.
1705 unshift (@$x, 0);
1706 # calculate sqrt($x), $x is now one element to big, again. In the next
1707 # round we make that two, again.
1708 _sqrt($c,$x);
1709 }
1710 # $x is now one element to big, so truncate result by removing it
1711 splice (@$x,0,1);
1712 }
1713 else
1714 {
091c87b1 1715 # trial computation by starting with 2,4,8,16 etc until we overstep
3a427a11 1716 my $step;
091c87b1 1717 my $trial = _two();
1718
3a427a11 1719 # while still to do more than X steps
1720 do
091c87b1 1721 {
3a427a11 1722 $step = _two();
1723 while (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) < 0)
1724 {
1725 _mul ($c, $step, [2]);
1726 _add ($c, $trial, $step);
1727 }
1728
1729 # hit exactly?
1730 if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) == 0)
1731 {
1732 @$x = @$trial; # make copy while preserving ref to $x
1733 return $x;
1734 }
1735 # overstepped, so go back on step
1736 _sub($c, $trial, $step);
1737 } while (scalar @$step > 1 || $step->[0] > 128);
091c87b1 1738
3a427a11 1739 # reset step to 2
1740 $step = _two();
091c87b1 1741 # add two, because $trial cannot be exactly the result (otherwise we would
1742 # alrady have found it)
1743 _add($c, $trial, $step);
1744
3a427a11 1745 # and now add more and more (2,4,6,8,10 etc)
1746 while (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) < 0)
1747 {
1748 _add ($c, $trial, $step);
1749 }
091c87b1 1750
1751 # hit not exactly? (overstepped)
091c87b1 1752 if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) > 0)
1753 {
1754 _dec($c,$trial);
1755 }
3a427a11 1756
1757 # hit not exactly? (overstepped)
1758 # 80 too small, 81 slightly too big, 82 too big
091c87b1 1759 if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) > 0)
1760 {
3a427a11 1761 _dec ($c, $trial);
091c87b1 1762 }
3a427a11 1763
091c87b1 1764 @$x = @$trial; # make copy while preserving ref to $x
1765 return $x;
c38b2de2 1766 }
990fb837 1767 $x;
1768 }
1769
394e6ffb 1770##############################################################################
1771# binary stuff
0716bf9b 1772
394e6ffb 1773sub _and
1774 {
1775 my ($c,$x,$y) = @_;
0716bf9b 1776
394e6ffb 1777 # the shortcut makes equal, large numbers _really_ fast, and makes only a
1778 # very small performance drop for small numbers (e.g. something with less
1779 # than 32 bit) Since we optimize for large numbers, this is enabled.
1780 return $x if _acmp($c,$x,$y) == 0; # shortcut
0716bf9b 1781
394e6ffb 1782 my $m = _one(); my ($xr,$yr);
1783 my $mask = $AND_MASK;
1784
1785 my $x1 = $x;
1786 my $y1 = _copy($c,$y); # make copy
1787 $x = _zero();
1788 my ($b,$xrr,$yrr);
1789 use integer;
1790 while (!_is_zero($c,$x1) && !_is_zero($c,$y1))
1791 {
1792 ($x1, $xr) = _div($c,$x1,$mask);
1793 ($y1, $yr) = _div($c,$y1,$mask);
1794
1795 # make ints() from $xr, $yr
9b924220 1796 # this is when the AND_BITS are greater than $BASE and is slower for
394e6ffb 1797 # small (<256 bits) numbers, but faster for large numbers. Disabled
1798 # due to KISS principle
1799
1800# $b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; }
1801# $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; }
9b924220 1802# _add($c,$x, _mul($c, _new( $c, ($xrr & $yrr) ), $m) );
394e6ffb 1803
61f5c3f5 1804 # 0+ due to '&' doesn't work in strings
1805 _add($c,$x, _mul($c, [ 0+$xr->[0] & 0+$yr->[0] ], $m) );
394e6ffb 1806 _mul($c,$m,$mask);
1807 }
1808 $x;
0716bf9b 1809 }
1810
394e6ffb 1811sub _xor
0716bf9b 1812 {
394e6ffb 1813 my ($c,$x,$y) = @_;
1814
1815 return _zero() if _acmp($c,$x,$y) == 0; # shortcut (see -and)
1816
1817 my $m = _one(); my ($xr,$yr);
1818 my $mask = $XOR_MASK;
1819
1820 my $x1 = $x;
1821 my $y1 = _copy($c,$y); # make copy
1822 $x = _zero();
1823 my ($b,$xrr,$yrr);
1824 use integer;
1825 while (!_is_zero($c,$x1) && !_is_zero($c,$y1))
0716bf9b 1826 {
394e6ffb 1827 ($x1, $xr) = _div($c,$x1,$mask);
1828 ($y1, $yr) = _div($c,$y1,$mask);
1829 # make ints() from $xr, $yr (see _and())
1830 #$b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; }
1831 #$b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; }
9b924220 1832 #_add($c,$x, _mul($c, _new( $c, ($xrr ^ $yrr) ), $m) );
61f5c3f5 1833
1834 # 0+ due to '^' doesn't work in strings
1835 _add($c,$x, _mul($c, [ 0+$xr->[0] ^ 0+$yr->[0] ], $m) );
394e6ffb 1836 _mul($c,$m,$mask);
0716bf9b 1837 }
394e6ffb 1838 # the loop stops when the shorter of the two numbers is exhausted
1839 # the remainder of the longer one will survive bit-by-bit, so we simple
1840 # multiply-add it in
1841 _add($c,$x, _mul($c, $x1, $m) ) if !_is_zero($c,$x1);
1842 _add($c,$x, _mul($c, $y1, $m) ) if !_is_zero($c,$y1);
1843
1844 $x;
0716bf9b 1845 }
1846
394e6ffb 1847sub _or
0716bf9b 1848 {
394e6ffb 1849 my ($c,$x,$y) = @_;
0716bf9b 1850
394e6ffb 1851 return $x if _acmp($c,$x,$y) == 0; # shortcut (see _and)
0716bf9b 1852
394e6ffb 1853 my $m = _one(); my ($xr,$yr);
1854 my $mask = $OR_MASK;
0716bf9b 1855
394e6ffb 1856 my $x1 = $x;
1857 my $y1 = _copy($c,$y); # make copy
1858 $x = _zero();
1859 my ($b,$xrr,$yrr);
1860 use integer;
1861 while (!_is_zero($c,$x1) && !_is_zero($c,$y1))
1862 {
1863 ($x1, $xr) = _div($c,$x1,$mask);
1864 ($y1, $yr) = _div($c,$y1,$mask);
1865 # make ints() from $xr, $yr (see _and())
1866# $b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; }
1867# $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; }
9b924220 1868# _add($c,$x, _mul($c, _new( $c, ($xrr | $yrr) ), $m) );
394e6ffb 1869
61f5c3f5 1870 # 0+ due to '|' doesn't work in strings
1871 _add($c,$x, _mul($c, [ 0+$xr->[0] | 0+$yr->[0] ], $m) );
394e6ffb 1872 _mul($c,$m,$mask);
1873 }
1874 # the loop stops when the shorter of the two numbers is exhausted
1875 # the remainder of the longer one will survive bit-by-bit, so we simple
1876 # multiply-add it in
1877 _add($c,$x, _mul($c, $x1, $m) ) if !_is_zero($c,$x1);
1878 _add($c,$x, _mul($c, $y1, $m) ) if !_is_zero($c,$y1);
1879
1880 $x;
0716bf9b 1881 }
1882
61f5c3f5 1883sub _as_hex
1884 {
1885 # convert a decimal number to hex (ref to array, return ref to string)
1886 my ($c,$x) = @_;
1887
50109ad0 1888 # fits into one element (handle also 0x0 case)
03874afe 1889 return sprintf("0x%x",$x->[0]) if @$x == 1;
990fb837 1890
61f5c3f5 1891 my $x1 = _copy($c,$x);
1892
1893 my $es = '';
1ddff52a 1894 my ($xr, $h, $x10000);
1895 if ($] >= 5.006)
1896 {
1897 $x10000 = [ 0x10000 ]; $h = 'h4';
1898 }
1899 else
1900 {
1901 $x10000 = [ 0x1000 ]; $h = 'h3';
1902 }
091c87b1 1903 while (@$x1 != 1 || $x1->[0] != 0) # _is_zero()
61f5c3f5 1904 {
1905 ($x1, $xr) = _div($c,$x1,$x10000);
7b29e1e6 1906 $es .= unpack($h,pack('V',$xr->[0]));
61f5c3f5 1907 }
1908 $es = reverse $es;
1909 $es =~ s/^[0]+//; # strip leading zeros
03874afe 1910 '0x' . $es; # return result prepended with 0x
61f5c3f5 1911 }
1912
1913sub _as_bin
1914 {
1915 # convert a decimal number to bin (ref to array, return ref to string)
1916 my ($c,$x) = @_;
1917
50109ad0 1918 # fits into one element (and Perl recent enough), handle also 0b0 case
091c87b1 1919 # handle zero case for older Perls
1920 if ($] <= 5.005 && @$x == 1 && $x->[0] == 0)
1921 {
9b924220 1922 my $t = '0b0'; return $t;
091c87b1 1923 }
1924 if (@$x == 1 && $] >= 5.006)
990fb837 1925 {
091c87b1 1926 my $t = sprintf("0b%b",$x->[0]);
9b924220 1927 return $t;
990fb837 1928 }
61f5c3f5 1929 my $x1 = _copy($c,$x);
1930
1931 my $es = '';
1ddff52a 1932 my ($xr, $b, $x10000);
1933 if ($] >= 5.006)
1934 {
1935 $x10000 = [ 0x10000 ]; $b = 'b16';
1936 }
1937 else
1938 {
1939 $x10000 = [ 0x1000 ]; $b = 'b12';
1940 }
091c87b1 1941 while (!(@$x1 == 1 && $x1->[0] == 0)) # _is_zero()
61f5c3f5 1942 {
1943 ($x1, $xr) = _div($c,$x1,$x10000);
7b29e1e6 1944 $es .= unpack($b,pack('v',$xr->[0]));
61f5c3f5 1945 }
1946 $es = reverse $es;
1947 $es =~ s/^[0]+//; # strip leading zeros
03874afe 1948 '0b' . $es; # return result prepended with 0b
61f5c3f5 1949 }
1950
7b29e1e6 1951sub _as_oct
1952 {
1953 # convert a decimal number to octal (ref to array, return ref to string)
1954 my ($c,$x) = @_;
1955
50109ad0 1956 # fits into one element (handle also 0 case)
7b29e1e6 1957 return sprintf("0%o",$x->[0]) if @$x == 1;
1958
1959 my $x1 = _copy($c,$x);
1960
1961 my $es = '';
1962 my $xr;
1963 my $x1000 = [ 0100000 ];
1964 while (@$x1 != 1 || $x1->[0] != 0) # _is_zero()
1965 {
1966 ($x1, $xr) = _div($c,$x1,$x1000);
1967 $es .= reverse sprintf("%05o", $xr->[0]);
1968 }
1969 $es = reverse $es;
1970 $es =~ s/^[0]+//; # strip leading zeros
1971 '0' . $es; # return result prepended with 0
1972 }
1973
1974sub _from_oct
1975 {
50109ad0 1976 # convert a octal number to decimal (string, return ref to array)
7b29e1e6 1977 my ($c,$os) = @_;
1978
1979 # for older Perls, play safe
1980 my $m = [ 0100000 ];
1981 my $d = 5; # 5 digits at a time
1982
1983 my $mul = _one();
1984 my $x = _zero();
1985
1986 my $len = int( (length($os)-1)/$d ); # $d digit parts, w/o the '0'
1987 my $val; my $i = -$d;
1988 while ($len >= 0)
1989 {
1990 $val = substr($os,$i,$d); # get oct digits
1991 $val = oct($val);
1992 $i -= $d; $len --;
1993 my $adder = [ $val ];
1994 _add ($c, $x, _mul ($c, $adder, $mul ) ) if $val != 0;
1995 _mul ($c, $mul, $m ) if $len >= 0; # skip last mul
1996 }
1997 $x;
1998 }
1999
394e6ffb 2000sub _from_hex
0716bf9b 2001 {
50109ad0 2002 # convert a hex number to decimal (string, return ref to array)
394e6ffb 2003 my ($c,$hs) = @_;
0716bf9b 2004
2d2b2744 2005 my $m = _new($c, 0x10000000); # 28 bit at a time (<32 bit!)
03874afe 2006 my $d = 7; # 7 digits at a time
2007 if ($] <= 5.006)
2008 {
2009 # for older Perls, play safe
2010 $m = [ 0x10000 ]; # 16 bit at a time (<32 bit!)
2011 $d = 4; # 4 digits at a time
2012 }
2013
394e6ffb 2014 my $mul = _one();
394e6ffb 2015 my $x = _zero();
0716bf9b 2016
03874afe 2017 my $len = int( (length($hs)-2)/$d ); # $d digit parts, w/o the '0x'
2018 my $val; my $i = -$d;
394e6ffb 2019 while ($len >= 0)
2020 {
03874afe 2021 $val = substr($hs,$i,$d); # get hex digits
7b29e1e6 2022 $val =~ s/^0x// if $len == 0; # for last part only because
394e6ffb 2023 $val = hex($val); # hex does not like wrong chars
03874afe 2024 $i -= $d; $len --;
2d2b2744 2025 my $adder = [ $val ];
2026 # if the resulting number was to big to fit into one element, create a
2027 # two-element version (bug found by Mark Lakata - Thanx!)
2028 if (CORE::length($val) > $BASE_LEN)
2029 {
2030 $adder = _new($c,$val);
2031 }
2032 _add ($c, $x, _mul ($c, $adder, $mul ) ) if $val != 0;
394e6ffb 2033 _mul ($c, $mul, $m ) if $len >= 0; # skip last mul
2034 }
2035 $x;
2036 }
2037
2038sub _from_bin
0716bf9b 2039 {
50109ad0 2040 # convert a hex number to decimal (string, return ref to array)
394e6ffb 2041 my ($c,$bs) = @_;
0716bf9b 2042
091c87b1 2043 # instead of converting X (8) bit at a time, it is faster to "convert" the
13a12e00 2044 # number to hex, and then call _from_hex.
2045
9b924220 2046 my $hs = $bs;
13a12e00 2047 $hs =~ s/^[+-]?0b//; # remove sign and 0b
2048 my $l = length($hs); # bits
2049 $hs = '0' x (8-($l % 8)) . $hs if ($l % 8) != 0; # padd left side w/ 0
03874afe 2050 my $h = '0x' . unpack('H*', pack ('B*', $hs)); # repack as hex
091c87b1 2051
03874afe 2052 $c->_from_hex($h);
0716bf9b 2053 }
2054
07d34614 2055##############################################################################
2056# special modulus functions
2057
56d9de68 2058sub _modinv
d614cd8b 2059 {
56d9de68 2060 # modular inverse
2061 my ($c,$x,$y) = @_;
1ddff52a 2062
56d9de68 2063 my $u = _zero($c); my $u1 = _one($c);
2064 my $a = _copy($c,$y); my $b = _copy($c,$x);
1ddff52a 2065
2066 # Euclid's Algorithm for bgcd(), only that we calc bgcd() ($a) and the
56d9de68 2067 # result ($u) at the same time. See comments in BigInt for why this works.
2068 my $q;
2069 ($a, $q, $b) = ($b, _div($c,$a,$b)); # step 1
2070 my $sign = 1;
1ddff52a 2071 while (!_is_zero($c,$b))
2072 {
56d9de68 2073 my $t = _add($c, # step 2:
2074 _mul($c,_copy($c,$u1), $q) , # t = u1 * q
2075 $u ); # + u
2076 $u = $u1; # u = u1, u1 = t
2077 $u1 = $t;
2078 $sign = -$sign;
2079 ($a, $q, $b) = ($b, _div($c,$a,$b)); # step 1
1ddff52a 2080 }
2081
2082 # if the gcd is not 1, then return NaN
56d9de68 2083 return (undef,undef) unless _is_one($c,$a);
2084
03874afe 2085 ($u1, $sign == 1 ? '+' : '-');
d614cd8b 2086 }
2087
2088sub _modpow
2089 {
2090 # modulus of power ($x ** $y) % $z
07d34614 2091 my ($c,$num,$exp,$mod) = @_;
2092
2093 # in the trivial case,
2094 if (_is_one($c,$mod))
2095 {
2096 splice @$num,0,1; $num->[0] = 0;
2097 return $num;
2098 }
2099 if ((scalar @$num == 1) && (($num->[0] == 0) || ($num->[0] == 1)))
2100 {
2101 $num->[0] = 1;
2102 return $num;
2103 }
1ddff52a 2104
2105# $num = _mod($c,$num,$mod); # this does not make it faster
07d34614 2106
2107 my $acc = _copy($c,$num); my $t = _one();
2108
9b924220 2109 my $expbin = _as_bin($c,$exp); $expbin =~ s/^0b//;
1ddff52a 2110 my $len = length($expbin);
2111 while (--$len >= 0)
07d34614 2112 {
1ddff52a 2113 if ( substr($expbin,$len,1) eq '1') # is_odd
07d34614 2114 {
2115 _mul($c,$t,$acc);
2116 $t = _mod($c,$t,$mod);
2117 }
2118 _mul($c,$acc,$acc);
2119 $acc = _mod($c,$acc,$mod);
07d34614 2120 }
2121 @$num = @$t;
2122 $num;
d614cd8b 2123 }
2124
9b924220 2125sub _gcd
2126 {
2127 # greatest common divisor
2128 my ($c,$x,$y) = @_;
2129
b68b7ab1 2130 while ( (scalar @$y != 1) || ($y->[0] != 0) ) # while ($y != 0)
9b924220 2131 {
2132 my $t = _copy($c,$y);
2133 $y = _mod($c, $x, $y);
2134 $x = $t;
2135 }
2136 $x;
2137 }
2138
394e6ffb 2139##############################################################################
2140##############################################################################
2141
0716bf9b 21421;
2143__END__
2144
2145=head1 NAME
2146
2147Math::BigInt::Calc - Pure Perl module to support Math::BigInt
2148
2149=head1 SYNOPSIS
2150
ee15d750 2151Provides support for big integer calculations. Not intended to be used by other
091c87b1 2152modules. Other modules which sport the same functions can also be used to support
2153Math::BigInt, like Math::BigInt::GMP or Math::BigInt::Pari.
0716bf9b 2154
2155=head1 DESCRIPTION
2156
027dc388 2157In order to allow for multiple big integer libraries, Math::BigInt was
2158rewritten to use library modules for core math routines. Any module which
2159follows the same API as this can be used instead by using the following:
0716bf9b 2160
ee15d750 2161 use Math::BigInt lib => 'libname';
0716bf9b 2162
027dc388 2163'libname' is either the long name ('Math::BigInt::Pari'), or only the short
2164version like 'Pari'.
2165
990fb837 2166=head1 STORAGE
2167
2168=head1 METHODS
0716bf9b 2169
027dc388 2170The following functions MUST be defined in order to support the use by
9b924220 2171Math::BigInt v1.70 or later:
0716bf9b 2172
50109ad0 2173 api_version() return API version, 1 for v1.70, 2 for v1.83
0716bf9b 2174 _new(string) return ref to new object from ref to decimal string
2175 _zero() return a new object with value 0
2176 _one() return a new object with value 1
9b924220 2177 _two() return a new object with value 2
2178 _ten() return a new object with value 10
0716bf9b 2179
2180 _str(obj) return ref to a string representing the object
2181 _num(obj) returns a Perl integer/floating point number
2182 NOTE: because of Perl numeric notation defaults,
2183 the _num'ified obj may lose accuracy due to
3c4b39be 2184 machine-dependent floating point size limitations
0716bf9b 2185
2186 _add(obj,obj) Simple addition of two objects
2187 _mul(obj,obj) Multiplication of two objects
2188 _div(obj,obj) Division of the 1st object by the 2nd
b22b3e31 2189 In list context, returns (result,remainder).
2190 NOTE: this is integer math, so no
2191 fractional part will be returned.
990fb837 2192 The second operand will be not be 0, so no need to
2193 check for that.
b22b3e31 2194 _sub(obj,obj) Simple subtraction of 1 object from another
0716bf9b 2195 a third, optional parameter indicates that the params
2196 are swapped. In this case, the first param needs to
2197 be preserved, while you can destroy the second.
2198 sub (x,y,1) => return x - y and keep x intact!
3c4b39be 2199 _dec(obj) decrement object by one (input is guaranteed to be > 0)
e745a66c 2200 _inc(obj) increment object by one
2201
0716bf9b 2202
2203 _acmp(obj,obj) <=> operator for objects (return -1, 0 or 1)
2204
2205 _len(obj) returns count of the decimal digits of the object
2206 _digit(obj,n) returns the n'th decimal digit of object
2207
9b924220 2208 _is_one(obj) return true if argument is 1
2209 _is_two(obj) return true if argument is 2
2210 _is_ten(obj) return true if argument is 10
0716bf9b 2211 _is_zero(obj) return true if argument is 0
2212 _is_even(obj) return true if argument is even (0,2,4,6..)
2213 _is_odd(obj) return true if argument is odd (1,3,5,7..)
2214
2215 _copy return a ref to a true copy of the object
2216
2217 _check(obj) check whether internal representation is still intact
2218 return 0 for ok, otherwise error message as string
2219
50109ad0 2220 _from_hex(str) return new object from a hexadecimal string
2221 _from_bin(str) return new object from a binary string
2222 _from_oct(str) return new object from an octal string
0716bf9b 2223
9b924220 2224 _as_hex(str) return string containing the value as
ee15d750 2225 unsigned hex string, with the '0x' prepended.
2226 Leading zeros must be stripped.
2227 _as_bin(str) Like as_hex, only as binary string containing only
2228 zeros and ones. Leading zeros must be stripped and a
2229 '0b' must be prepended.
2230
0716bf9b 2231 _rsft(obj,N,B) shift object in base B by N 'digits' right
2232 _lsft(obj,N,B) shift object in base B by N 'digits' left
2233
2234 _xor(obj1,obj2) XOR (bit-wise) object 1 with object 2
dccbb853 2235 Note: XOR, AND and OR pad with zeros if size mismatches
0716bf9b 2236 _and(obj1,obj2) AND (bit-wise) object 1 with object 2
2237 _or(obj1,obj2) OR (bit-wise) object 1 with object 2
2238
50109ad0 2239 _mod(obj1,obj2) Return remainder of div of the 1st by the 2nd object
990fb837 2240 _sqrt(obj) return the square root of object (truncated to int)
2241 _root(obj) return the n'th (n >= 3) root of obj (truncated to int)
b3abae2a 2242 _fac(obj) return factorial of object 1 (1*2*3*4..)
50109ad0 2243 _pow(obj1,obj2) return object 1 to the power of object 2
b282a552 2244 return undef for NaN
b22b3e31 2245 _zeros(obj) return number of trailing decimal zeros
d614cd8b 2246 _modinv return inverse modulus
2247 _modpow return modulus of power ($x ** $y) % $z
091c87b1 2248 _log_int(X,N) calculate integer log() of X in base N
2249 X >= 0, N >= 0 (return undef for NaN)
8df1e0a2 2250 returns (RESULT, EXACT) where EXACT is:
2251 1 : result is exactly RESULT
2252 0 : result was truncated to RESULT
2253 undef : unknown whether result is exactly RESULT
9b924220 2254 _gcd(obj,obj) return Greatest Common Divisor of two objects
2255
50109ad0 2256The following functions are REQUIRED for an api_version of 2 or greater:
2257
2258 _1ex($x) create the number 1Ex where x >= 0
2259 _alen(obj) returns approximate count of the decimal digits of the
2260 object. This estimate MUST always be greater or equal
2261 to what _len() returns.
2262 _nok(n,k) calculate n over k (binomial coefficient)
2263
9b924220 2264The following functions are optional, and can be defined if the underlying lib
2265has a fast way to do them. If undefined, Math::BigInt will use pure Perl (hence
2266slow) fallback routines to emulate these:
2267
2268 _signed_or
2269 _signed_and
2270 _signed_xor
2271
b22b3e31 2272Input strings come in as unsigned but with prefix (i.e. as '123', '0xabc'
0716bf9b 2273or '0b1101').
2274
990fb837 2275So the library needs only to deal with unsigned big integers. Testing of input
2276parameter validity is done by the caller, so you need not worry about
2277underflow (f.i. in C<_sub()>, C<_dec()>) nor about division by zero or similar
2278cases.
574bacfe 2279
2280The first parameter can be modified, that includes the possibility that you
2281return a reference to a completely different object instead. Although keeping
50109ad0 2282the reference and just changing its contents is preferred over creating and
dccbb853 2283returning a different reference.
574bacfe 2284
990fb837 2285Return values are always references to objects, strings, or true/false for
3c4b39be 2286comparison routines.
990fb837 2287
574bacfe 2288=head1 WRAP YOUR OWN
2289
2290If you want to port your own favourite c-lib for big numbers to the
2291Math::BigInt interface, you can take any of the already existing modules as
2292a rough guideline. You should really wrap up the latest BigInt and BigFloat
bd05a461 2293testsuites with your module, and replace in them any of the following:
574bacfe 2294
2295 use Math::BigInt;
2296
bd05a461 2297by this:
574bacfe 2298
2299 use Math::BigInt lib => 'yourlib';
2300
2301This way you ensure that your library really works 100% within Math::BigInt.
0716bf9b 2302
2303=head1 LICENSE
2304
2305This program is free software; you may redistribute it and/or modify it under
2306the same terms as Perl itself.
2307
2308=head1 AUTHORS
2309
2310Original math code by Mark Biggar, rewritten by Tels L<http://bloodgate.com/>
990fb837 2311in late 2000.
0716bf9b 2312Seperated from BigInt and shaped API with the help of John Peacock.
b68b7ab1 2313
7b29e1e6 2314Fixed, speed-up, streamlined and enhanced by Tels 2001 - 2007.
0716bf9b 2315
2316=head1 SEE ALSO
2317
50109ad0 2318L<Math::BigInt>, L<Math::BigFloat>,
990fb837 2319L<Math::BigInt::GMP>, L<Math::BigInt::FastCalc> and L<Math::BigInt::Pari>.
0716bf9b 2320
2321=cut