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