calc.pm

Astercon2 开源软交换 2.2.0

    $i++;
    }
  return "Illegal part '$e' at pos $i (tested: $try)" if $i < $j;
  0;
  }


###############################################################################

sub _mod
  {
  # if possible, use mod shortcut
  my ($c,$x,$yo) = @_;

  # slow way since $y to big
  if (scalar @$yo > 1)
    {
    my ($xo,$rem) = _div($c,$x,$yo);
    return $rem;
    }

  my $y = $yo->[0];
  # both are single element arrays
  if (scalar @$x == 1)
    {
    $x->[0] %= $y;
    return $x;
    }

  # @y is a single element, but @x has more than one element
  my $b = $BASE % $y;
  if ($b == 0)
    {
    # when BASE % Y == 0 then (B * BASE) % Y == 0
    # (B * BASE) % $y + A % Y => A % Y
    # so need to consider only last element: O(1)
    $x->[0] %= $y;
    }
  elsif ($b == 1)
    {
    # else need to go through all elements: O(N), but loop is a bit simplified
    my $r = 0;
    foreach (@$x)
      {
      $r = ($r + $_) % $y;		# not much faster, but heh...
      #$r += $_ % $y; $r %= $y;
      }
    $r = 0 if $r == $y;
    $x->[0] = $r;
    }
  else
    {
    # else need to go through all elements: O(N)
    my $r = 0; my $bm = 1;
    foreach (@$x)
      {
      $r = ($_ * $bm + $r) % $y;
      $bm = ($bm * $b) % $y;

      #$r += ($_ % $y) * $bm;
      #$bm *= $b;
      #$bm %= $y;
      #$r %= $y;
      }
    $r = 0 if $r == $y;
    $x->[0] = $r;
    }
  splice (@$x,1);		# keep one element of $x
  $x;
  }

##############################################################################
# shifts

sub _rsft
  {
  my ($c,$x,$y,$n) = @_;

  if ($n != 10)
    {
    $n = _new($c,$n); return _div($c,$x, _pow($c,$n,$y));
    }

  # shortcut (faster) for shifting by 10)
  # multiples of $BASE_LEN
  my $dst = 0;				# destination
  my $src = _num($c,$y);		# as normal int
  my $xlen = (@$x-1)*$BASE_LEN+length(int($x->[-1]));  # len of x in digits
  if ($src >= $xlen or ($src == $xlen and ! defined $x->[1]))
    {
    # 12345 67890 shifted right by more than 10 digits => 0
    splice (@$x,1);                    # leave only one element
    $x->[0] = 0;                       # set to zero
    return $x;
    }
  my $rem = $src % $BASE_LEN;		# remainder to shift
  $src = int($src / $BASE_LEN);		# source
  if ($rem == 0)
    {
    splice (@$x,0,$src);		# even faster, 38.4 => 39.3
    }
  else
    {
    my $len = scalar @$x - $src;	# elems to go
    my $vd; my $z = '0'x $BASE_LEN;
    $x->[scalar @$x] = 0;		# avoid || 0 test inside loop
    while ($dst < $len)
      {
      $vd = $z.$x->[$src];
      $vd = substr($vd,-$BASE_LEN,$BASE_LEN-$rem);
      $src++;
      $vd = substr($z.$x->[$src],-$rem,$rem) . $vd;
      $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN;
      $x->[$dst] = int($vd);
      $dst++;
      }
    splice (@$x,$dst) if $dst > 0;		# kill left-over array elems
    pop @$x if $x->[-1] == 0 && @$x > 1;	# kill last element if 0
    } # else rem == 0
  $x;
  }

sub _lsft
  {
  my ($c,$x,$y,$n) = @_;

  if ($n != 10)
    {
    $n = _new($c,$n); return _mul($c,$x, _pow($c,$n,$y));
    }

  # shortcut (faster) for shifting by 10) since we are in base 10eX
  # multiples of $BASE_LEN:
  my $src = scalar @$x;			# source
  my $len = _num($c,$y);		# shift-len as normal int
  my $rem = $len % $BASE_LEN;		# remainder to shift
  my $dst = $src + int($len/$BASE_LEN);	# destination
  my $vd;				# further speedup
  $x->[$src] = 0;			# avoid first ||0 for speed
  my $z = '0' x $BASE_LEN;
  while ($src >= 0)
    {
    $vd = $x->[$src]; $vd = $z.$vd;
    $vd = substr($vd,-$BASE_LEN+$rem,$BASE_LEN-$rem);
    $vd .= $src > 0 ? substr($z.$x->[$src-1],-$BASE_LEN,$rem) : '0' x $rem;
    $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN;
    $x->[$dst] = int($vd);
    $dst--; $src--;
    }
  # set lowest parts to 0
  while ($dst >= 0) { $x->[$dst--] = 0; }
  # fix spurios last zero element
  splice @$x,-1 if $x->[-1] == 0;
  $x;
  }

sub _pow
  {
  # power of $x to $y
  # ref to array, ref to array, return ref to array
  my ($c,$cx,$cy) = @_;

  if (scalar @$cy == 1 && $cy->[0] == 0)
    {
    splice (@$cx,1); $cx->[0] = 1;		# y == 0 => x => 1
    return $cx;
    }
  if ((scalar @$cx == 1 && $cx->[0] == 1) ||	#    x == 1
      (scalar @$cy == 1 && $cy->[0] == 1))	# or y == 1
    {
    return $cx;
    }
  if (scalar @$cx == 1 && $cx->[0] == 0)
    {
    splice (@$cx,1); $cx->[0] = 0;		# 0 ** y => 0 (if not y <= 0)
    return $cx;
    }

  my $pow2 = _one();

  my $y_bin = _as_bin($c,$cy); $y_bin =~ s/^0b//;
  my $len = length($y_bin);
  while (--$len > 0)
    {
    _mul($c,$pow2,$cx) if substr($y_bin,$len,1) eq '1';		# is odd?
    _mul($c,$cx,$cx);
    }

  _mul($c,$cx,$pow2);
  $cx;
  }

sub _fac
  {
  # factorial of $x
  # ref to array, return ref to array
  my ($c,$cx) = @_;

  if ((@$cx == 1) && ($cx->[0] <= 2))
    {
    $cx->[0] ||= 1;		# 0 => 1, 1 => 1, 2 => 2
    return $cx;
    }

  # go forward until $base is exceeded
  # limit is either $x steps (steps == 100 means a result always too high) or
  # $base.
  my $steps = 100; $steps = $cx->[0] if @$cx == 1;
  my $r = 2; my $cf = 3; my $step = 2; my $last = $r;
  while ($r*$cf < $BASE && $step < $steps)
    {
    $last = $r; $r *= $cf++; $step++;
    }
  if ((@$cx == 1) && $step == $cx->[0])
    {
    # completely done, so keep reference to $x and return
    $cx->[0] = $r;
    return $cx;
    }
  
  # now we must do the left over steps
  my $n;					# steps still to do
  if (scalar @$cx == 1)
    {
    $n = $cx->[0];
    }
  else
    {
    $n = _copy($c,$cx);
    }

  $cx->[0] = $last; splice (@$cx,1);		# keep ref to $x
  my $zero_elements = 0;

  # do left-over steps fit into a scalar?
  if (ref $n eq 'ARRAY')
    {
    # No, so use slower inc() & cmp()
    $step = [$step];
    while (_acmp($step,$n) <= 0)
      {
      # as soon as the last element of $cx is 0, we split it up and remember
      # how many zeors we got so far. The reason is that n! will accumulate
      # zeros at the end rather fast.
      if ($cx->[0] == 0)
        {
        $zero_elements ++; shift @$cx;
        }
      _mul($c,$cx,$step); _inc($c,$step);
      }
    }
  else
    {
    # Yes, so we can speed it up slightly
    while ($step <= $n)
      {
      # When the last element of $cx is 0, we split it up and remember
      # how many we got so far. The reason is that n! will accumulate
      # zeros at the end rather fast.
      if ($cx->[0] == 0)
        {
        $zero_elements ++; shift @$cx;
        }
      _mul($c,$cx,[$step]); $step++;
      }
    }
  # multiply in the zeros again
  while ($zero_elements-- > 0)
    {
    unshift @$cx, 0; 
    }
  $cx;			# return result
  }

#############################################################################

sub _log_int
  {
  # calculate integer log of $x to base $base
  # ref to array, ref to array - return ref to array
  my ($c,$x,$base) = @_;

  # X == 0 => NaN
  return if (scalar @$x == 1 && $x->[0] == 0);
  # BASE 0 or 1 => NaN
  return if (scalar @$base == 1 && $base->[0] < 2);
  my $cmp = _acmp($c,$x,$base); # X == BASE => 1
  if ($cmp == 0)
    {
    splice (@$x,1); $x->[0] = 1;
    return ($x,1)
    }
  # X < BASE
  if ($cmp < 0)
    {
    splice (@$x,1); $x->[0] = 0;
    return ($x,undef);
    }

  # this trial multiplication is very fast, even for large counts (like for
  # 2 ** 1024, since this still requires only 1024 very fast steps
  # (multiplication of a large number by a very small number is very fast))
  my $x_org = _copy($c,$x);		# preserve x
  splice(@$x,1); $x->[0] = 1;		# keep ref to $x

  my $trial = _copy($c,$base);

  # XXX TODO this only works if $base has only one element
  if (scalar @$base == 1)
    {
    # compute int ( length_in_base_10(X) / ( log(base) / log(10) ) )
    my $len = _len($c,$x_org);
    my $res = int($len / (log($base->[0]) / log(10))) || 1; # avoid $res == 0

    $x->[0] = $res;
    $trial = _pow ($c, _copy($c, $base), $x);
    my $a = _acmp($x,$trial,$x_org);
    return ($x,1) if $a == 0;
    # we now know that $res is too small
    if ($res < 0)
      {
      _mul($c,$trial,$base); _add($c, $x, [1]);
      }
    else
      {
      # or too big
      _div($c,$trial,$base); _sub($c, $x, [1]);
      }
    # did we now get the right result?
    $a = _acmp($x,$trial,$x_org);
    return ($x,1) if $a == 0;		# yes, exactly
    # still too big
    if ($a > 0)
      {
      _div($c,$trial,$base); _sub($c, $x, [1]);
      }
    } 
  
  # simple loop that increments $x by two in each step, possible overstepping
  # the real result by one

  my $a;
  my $base_mul = _mul($c, _copy($c,$base), $base);

  while (($a = _acmp($c,$trial,$x_org)) < 0)
    {
    _mul($c,$trial,$base_mul); _add($c, $x, [2]);
    }

  my $exact = 1;
  if ($a > 0)
    {
    # overstepped the result
    _dec($c, $x);
    _div($c,$trial,$base);
    $a = _acmp($c,$trial,$x_org);
    if ($a > 0)
      {
      _dec($c, $x);
      }
    $exact = 0 if $a != 0;
    }
  
  ($x,$exact);				# return result
  }

# for debugging:
  use constant DEBUG => 0;
  my $steps = 0;
  sub steps { $steps };

sub _sqrt
  {
  # square-root of $x in place
  # Compute a guess of the result (by rule of thumb), then improve it via
  # Newton's method.
  my ($c,$x) = @_;

  if (scalar @$x == 1)
    {
    # fit's into one Perl scalar, so result can be computed directly
    $x->[0] = int(sqrt($x->[0]));
    return $x;
    } 
  my $y = _copy($c,$x);
  # hopefully _len/2 is < $BASE, the -1 is to always undershot the guess
  # since our guess will "grow"
  my $l = int((_len($c,$x)-1) / 2);	

  my $lastelem = $x->[-1];					# for guess
  my $elems = scalar @$x - 1;
  # not enough digits, but could have more?
  if ((length($lastelem) <= 3) && ($elems > 1))
    {
    # right-align with zero pad
    my $len = length($lastelem) & 1;
    print "$lastelem => " if DEBUG;
    $lastelem .= substr($x->[-2] . '0' x $BASE_LEN,0,$BASE_LEN);
    # former odd => make odd again, or former even to even again
    $lastelem = $lastelem / 10 if (length($lastelem) & 1) != $len;
    print "$lastelem\n" if DEBUG;
    }

  # construct $x (instead of _lsft($c,$x,$l,10)
  my $r = $l % $BASE_LEN;	# 10000 00000 00000 00000 ($BASE_LEN=5)
  $l = int($l / $BASE_LEN);
  print "l =  $l " if DEBUG;

  splice @$x,$l;		# keep ref($x), but modify it

  # we make the first part of the guess not '1000...0' but int(sqrt($lastelem))
  # that gives us:
  # 14400 00000 => sqrt(14400) => guess first digits to be 120
  # 144000 000000 => sqrt(144000) => guess 379

  print "$lastelem (elems $elems) => " if DEBUG;
  $lastelem = $lastelem / 10 if ($elems & 1 == 1);		# odd or even?
  my $g = sqrt($lastelem); $g =~ s/\.//;			# 2.345 => 2345
  $r -= 1 if $elems & 1 == 0;					# 70 => 7

  # padd with zeros if result is too short
  $x->[$l--] = int(substr($g . '0' x $r,0,$r+1));
  print "now ",$x->[-1] if DEBUG;
  print " would have been ", int('1' . '0' x $r),"\n" if DEBUG;

  # If @$x > 1, we could compute the second elem of the guess, too, to create
  # an even better guess. Not implemented yet. Does it improve performance?
  $x->[$l--] = 0 while ($l >= 0);	# all other digits of guess are zero

  print "start x= ",_str($c,$x),"\n" if DEBUG;
  my $two = _two();
  my $last = _zero();
  my $lastlast = _zero();
  $steps = 0 if DEBUG;
  while (_acmp($c,$last,$x) != 0 && _acmp($c,$lastlast,$x) != 0)
    {
    $steps++ if DEBUG;
    $lastlast = _copy($c,$last);
    $last = _copy($c,$x);
    _add($c,$x, _div($c,_copy($c,$y),$x));
    _div($c,$x, $two );
    print " x= ",_str($c,$x),"\n" if DEBUG;
    }
  print "\nsteps in sqrt: $steps, " if DEBUG;
  _dec($c,$x) if _acmp($c,$y,_mul($c,_copy($c,$x),$x)) < 0;	# overshot? 
  print " final ",$x->[-1],"\n" if DEBUG;
  $x;
  }

sub _root
  {
  # take n'th root of $x in place (n >= 3)
  my ($c,$x,$n) = @_;
 
  if (scalar @$x == 1)
    {
    if (scalar @$n > 1)
      {
      # result will always be smaller than 2 so trunc to 1 at once
      $x->[0] = 1;
      }
    else
      {
      # fit's into one Perl scalar, so result can be computed directly
      # cannot use int() here, because it rounds wrongly (try 
      # (81 ** 3) ** (1/3) to see what I mean)
      #$x->[0] = int( $x->[0] ** (1 / $n->[0]) );
      # round to 8 digits, then truncate result to integer
      $x->[0] = int ( sprintf ("%.8f", $x->[0] ** (1 / $n->[0]) ) );
      }
    return $x;
    } 

  # we know now that X is more than one element long

  # if $n is a power of two, we can repeatedly take sqrt($X) and find the
  # proper result, because sqrt(sqrt($x)) == root($x,4)
  my $b = _as_bin($c,$n);
  if ($b =~ /0b1(0+)$/)
    {
    my $count = CORE::length($1);	# 0b100 => len('00') => 2
    my $cnt = $count;			# counter for loop
    unshift (@$x, 0);			# add one element, together with one
					# more below in the loop this makes 2
    while ($cnt-- > 0)
      {
      # 'inflate' $X by adding one element, basically computing
      # $x * $BASE * $BASE. This gives us more $BASE_LEN digits for result
      # since len(sqrt($X)) approx == len($x) / 2.
      unshift (@$x, 0);
      # calculate sqrt($x), $x is now one element to big, again. In the next
      # round we make that two, again.
      _sqrt($c,$x);
      }
    # $x is now one element to big, so truncate result by removing it
    splice (@$x,0,1);
    } 
  else
    {
    # trial computation by starting with 2,4,8,16 etc until we overstep
    my $step;
    my $trial = _two();

    # while still to do more than X steps
    do
      {
      $step = _two();
      while (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) < 0)
        {
        _mul ($c, $step, [2]);
        _add ($c, $trial, $step);
        }

      # hit exactly?
      if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) == 0)
        {
        @$x = @$trial;			# make copy while preserving ref to $x
        return $x;
        }
      # overstepped, so go back on step
      _sub($c, $trial, $step);
      } while (scalar @$step > 1 || $step->[0] > 128);

    # reset step to 2
    $step = _two();
    # add two, because $trial cannot be exactly the result (otherwise we would