bigrat.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

  my $self = shift;
  $self->{_n} = $MBI->_zero();
  $self->{_d} = $MBI->_one();
  }

##############################################################################
# mul/add/div etc

sub badd
  {
  # add two rational numbers

  # set up parameters
  my ($self,$x,$y,@r) = (ref($_[0]),@_);
  # objectify is costly, so avoid it
  if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
    {
    ($self,$x,$y,@r) = objectify(2,@_);
    }

  # +inf + +inf => +inf,  -inf + -inf => -inf
  return $x->binf(substr($x->{sign},0,1))
    if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/;

  # +inf + -inf or -inf + +inf => NaN
  return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);

  #  1   1    gcd(3,4) = 1    1*3 + 1*4    7
  #  - + -                  = --------- = --                 
  #  4   3                      4*3       12

  # we do not compute the gcd() here, but simple do:
  #  5   7    5*3 + 7*4   43
  #  - + -  = --------- = --                 
  #  4   3       4*3      12
 
  # and bnorm() will then take care of the rest

  # 5 * 3
  $x->{_n} = $MBI->_mul( $x->{_n}, $y->{_d});

  # 7 * 4
  my $m = $MBI->_mul( $MBI->_copy( $y->{_n} ), $x->{_d} );

  # 5 * 3 + 7 * 4
  ($x->{_n}, $x->{sign}) = _e_add( $x->{_n}, $m, $x->{sign}, $y->{sign});

  # 4 * 3
  $x->{_d} = $MBI->_mul( $x->{_d}, $y->{_d});

  # normalize result, and possible round
  $x->bnorm()->round(@r);
  }

sub bsub
  {
  # subtract two rational numbers

  # set up parameters
  my ($self,$x,$y,@r) = (ref($_[0]),@_);
  # objectify is costly, so avoid it
  if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
    {
    ($self,$x,$y,@r) = objectify(2,@_);
    }

  # flip sign of $x, call badd(), then flip sign of result
  $x->{sign} =~ tr/+-/-+/
    unless $x->{sign} eq '+' && $MBI->_is_zero($x->{_n});	# not -0
  $x->badd($y,@r);				# does norm and round
  $x->{sign} =~ tr/+-/-+/ 
    unless $x->{sign} eq '+' && $MBI->_is_zero($x->{_n});	# not -0
  $x;
  }

sub bmul
  {
  # multiply two rational numbers
  
  # set up parameters
  my ($self,$x,$y,@r) = (ref($_[0]),@_);
  # objectify is costly, so avoid it
  if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
    {
    ($self,$x,$y,@r) = objectify(2,@_);
    }

  return $x->bnan() if ($x->{sign} eq 'NaN' || $y->{sign} eq 'NaN');

  # inf handling
  if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
    {
    return $x->bnan() if $x->is_zero() || $y->is_zero();
    # result will always be +-inf:
    # +inf * +/+inf => +inf, -inf * -/-inf => +inf
    # +inf * -/-inf => -inf, -inf * +/+inf => -inf
    return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
    return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
    return $x->binf('-');
    }

  # x== 0 # also: or y == 1 or y == -1
  return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();

  # XXX TODO:
  # According to Knuth, this can be optimized by doing gcd twice (for d and n)
  # and reducing in one step. This would save us the bnorm() at the end.

  #  1   2    1 * 2    2    1
  #  - * - =  -----  = -  = -
  #  4   3    4 * 3    12   6
  
  $x->{_n} = $MBI->_mul( $x->{_n}, $y->{_n});
  $x->{_d} = $MBI->_mul( $x->{_d}, $y->{_d});

  # compute new sign
  $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-';

  $x->bnorm()->round(@r);
  }

sub bdiv
  {
  # (dividend: BRAT or num_str, divisor: BRAT or num_str) return
  # (BRAT,BRAT) (quo,rem) or BRAT (only rem)

  # set up parameters
  my ($self,$x,$y,@r) = (ref($_[0]),@_);
  # objectify is costly, so avoid it
  if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
    {
    ($self,$x,$y,@r) = objectify(2,@_);
    }

  return $self->_div_inf($x,$y)
   if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero());

  # x== 0 # also: or y == 1 or y == -1
  return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();

  # XXX TODO: list context, upgrade
  # According to Knuth, this can be optimized by doing gcd twice (for d and n)
  # and reducing in one step. This would save us the bnorm() at the end.

  # 1     1    1   3
  # -  /  - == - * -
  # 4     3    4   1
  
  $x->{_n} = $MBI->_mul( $x->{_n}, $y->{_d});
  $x->{_d} = $MBI->_mul( $x->{_d}, $y->{_n});

  # compute new sign 
  $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-';

  $x->bnorm()->round(@r);
  $x;
  }

sub bmod
  {
  # compute "remainder" (in Perl way) of $x / $y

  # set up parameters
  my ($self,$x,$y,@r) = (ref($_[0]),@_);
  # objectify is costly, so avoid it
  if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
    {
    ($self,$x,$y,@r) = objectify(2,@_);
    }

  return $self->_div_inf($x,$y)
   if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero());

  return $x if $x->is_zero();           # 0 / 7 = 0, mod 0

  # compute $x - $y * floor($x/$y), keeping the sign of $x

  # copy x to u, make it positive and then do a normal division ($u/$y)
  my $u = bless { sign => '+' }, $self;
  $u->{_n} = $MBI->_mul( $MBI->_copy($x->{_n}), $y->{_d} );
  $u->{_d} = $MBI->_mul( $MBI->_copy($x->{_d}), $y->{_n} );
  
  # compute floor(u)
  if (! $MBI->_is_one($u->{_d}))
    {
    $u->{_n} = $MBI->_div($u->{_n},$u->{_d});	# 22/7 => 3/1 w/ truncate
    # no need to set $u->{_d} to 1, since below we set it to $y->{_d} anyway
    }
  
  # now compute $y * $u
  $u->{_d} = $MBI->_copy($y->{_d});		# 1 * $y->{_d}, see floor above
  $u->{_n} = $MBI->_mul($u->{_n},$y->{_n});

  my $xsign = $x->{sign}; $x->{sign} = '+';	# remember sign and make x positive
  # compute $x - $u
  $x->bsub($u);
  $x->{sign} = $xsign;				# put sign back

  $x->bnorm()->round(@r);
  }

##############################################################################
# bdec/binc

sub bdec
  {
  # decrement value (subtract 1)
  my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);

  return $x if $x->{sign} !~ /^[+-]$/;	# NaN, inf, -inf

  if ($x->{sign} eq '-')
    {
    $x->{_n} = $MBI->_add( $x->{_n}, $x->{_d});		# -5/2 => -7/2
    }
  else
    {
    if ($MBI->_acmp($x->{_n},$x->{_d}) < 0)		# n < d?
      {
      # 1/3 -- => -2/3
      $x->{_n} = $MBI->_sub( $MBI->_copy($x->{_d}), $x->{_n});
      $x->{sign} = '-';
      }
    else
      {
      $x->{_n} = $MBI->_sub($x->{_n}, $x->{_d}); 	# 5/2 => 3/2
      }
    }
  $x->bnorm()->round(@r);
  }

sub binc
  {
  # increment value (add 1)
  my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
  
  return $x if $x->{sign} !~ /^[+-]$/;	# NaN, inf, -inf

  if ($x->{sign} eq '-')
    {
    if ($MBI->_acmp($x->{_n},$x->{_d}) < 0)
      {
      # -1/3 ++ => 2/3 (overflow at 0)
      $x->{_n} = $MBI->_sub( $MBI->_copy($x->{_d}), $x->{_n});
      $x->{sign} = '+';
      }
    else
      {
      $x->{_n} = $MBI->_sub($x->{_n}, $x->{_d}); 	# -5/2 => -3/2
      }
    }
  else
    {
    $x->{_n} = $MBI->_add($x->{_n},$x->{_d});		# 5/2 => 7/2
    }
  $x->bnorm()->round(@r);
  }

##############################################################################
# is_foo methods (the rest is inherited)

sub is_int
  {
  # return true if arg (BRAT or num_str) is an integer
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);

  return 1 if ($x->{sign} =~ /^[+-]$/) &&	# NaN and +-inf aren't
    $MBI->_is_one($x->{_d});			# x/y && y != 1 => no integer
  0;
  }

sub is_zero
  {
  # return true if arg (BRAT or num_str) is zero
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);

  return 1 if $x->{sign} eq '+' && $MBI->_is_zero($x->{_n});
  0;
  }

sub is_one
  {
  # return true if arg (BRAT or num_str) is +1 or -1 if signis given
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);

  my $sign = $_[2] || ''; $sign = '+' if $sign ne '-';
  return 1
   if ($x->{sign} eq $sign && $MBI->_is_one($x->{_n}) && $MBI->_is_one($x->{_d}));
  0;
  }

sub is_odd
  {
  # return true if arg (BFLOAT or num_str) is odd or false if even
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);

  return 1 if ($x->{sign} =~ /^[+-]$/) &&		# NaN & +-inf aren't
    ($MBI->_is_one($x->{_d}) && $MBI->_is_odd($x->{_n})); # x/2 is not, but 3/1
  0;
  }

sub is_even
  {
  # return true if arg (BINT or num_str) is even or false if odd
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);

  return 0 if $x->{sign} !~ /^[+-]$/;			# NaN & +-inf aren't
  return 1 if ($MBI->_is_one($x->{_d})			# x/3 is never
     && $MBI->_is_even($x->{_n}));			# but 4/1 is
  0;
  }

##############################################################################
# parts() and friends

sub numerator
  {
  my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);

  # NaN, inf, -inf
  return Math::BigInt->new($x->{sign}) if ($x->{sign} !~ /^[+-]$/);

  my $n = Math::BigInt->new($MBI->_str($x->{_n})); $n->{sign} = $x->{sign};
  $n;
  }

sub denominator
  {
  my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);

  # NaN
  return Math::BigInt->new($x->{sign}) if $x->{sign} eq 'NaN';
  # inf, -inf
  return Math::BigInt->bone() if $x->{sign} !~ /^[+-]$/;
  
  Math::BigInt->new($MBI->_str($x->{_d}));
  }

sub parts
  {
  my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);

  my $c = 'Math::BigInt';

  return ($c->bnan(),$c->bnan()) if $x->{sign} eq 'NaN';
  return ($c->binf(),$c->binf()) if $x->{sign} eq '+inf';
  return ($c->binf('-'),$c->binf()) if $x->{sign} eq '-inf';

  my $n = $c->new( $MBI->_str($x->{_n}));
  $n->{sign} = $x->{sign};
  my $d = $c->new( $MBI->_str($x->{_d}));
  ($n,$d);
  }

sub length
  {
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);

  return $nan unless $x->is_int();
  $MBI->_len($x->{_n});				# length(-123/1) => length(123)
  }

sub digit
  {
  my ($self,$x,$n) = ref($_[0]) ? (undef,$_[0],$_[1]) : objectify(1,@_);

  return $nan unless $x->is_int();
  $MBI->_digit($x->{_n},$n || 0);		# digit(-123/1,2) => digit(123,2)
  }

##############################################################################
# special calc routines

sub bceil
  {
  my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);

  return $x if $x->{sign} !~ /^[+-]$/ ||	# not for NaN, inf
            $MBI->_is_one($x->{_d});		# 22/1 => 22, 0/1 => 0

  $x->{_n} = $MBI->_div($x->{_n},$x->{_d});	# 22/7 => 3/1 w/ truncate
  $x->{_d} = $MBI->_one();			# d => 1
  $x->{_n} = $MBI->_inc($x->{_n})
    if $x->{sign} eq '+';			# +22/7 => 4/1
  $x->{sign} = '+' if $MBI->_is_zero($x->{_n});	# -0 => 0
  $x;
  }

sub bfloor
  {
  my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);

  return $x if $x->{sign} !~ /^[+-]$/ ||	# not for NaN, inf
            $MBI->_is_one($x->{_d});		# 22/1 => 22, 0/1 => 0

  $x->{_n} = $MBI->_div($x->{_n},$x->{_d});	# 22/7 => 3/1 w/ truncate
  $x->{_d} = $MBI->_one();			# d => 1
  $x->{_n} = $MBI->_inc($x->{_n})
    if $x->{sign} eq '-';			# -22/7 => -4/1
  $x;
  }

sub bfac
  {
  my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);

  # if $x is not an integer
  if (($x->{sign} ne '+') || (!$MBI->_is_one($x->{_d})))
    {
    return $x->bnan();
    }

  $x->{_n} = $MBI->_fac($x->{_n});
  # since _d is 1, we don't need to reduce/norm the result
  $x->round(@r);
  }

sub bpow
  {
  # power ($x ** $y)

  # set up parameters
  my ($self,$x,$y,@r) = (ref($_[0]),@_);
  # objectify is costly, so avoid it
  if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
    {
    ($self,$x,$y,@r) = objectify(2,@_);
    }

  return $x if $x->{sign} =~ /^[+-]inf$/;       # -inf/+inf ** x
  return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
  return $x->bone(@r) if $y->is_zero();
  return $x->round(@r) if $x->is_one() || $y->is_one();

  if ($x->{sign} eq '-' && $MBI->_is_one($x->{_n}) && $MBI->_is_one($x->{_d}))
    {
    # if $x == -1 and odd/even y => +1/-1
    return $y->is_odd() ? $x->round(@r) : $x->babs()->round(@r);
    # my Casio FX-5500L has a bug here: -1 ** 2 is -1, but -1 * -1 is 1;
    }
  # 1 ** -y => 1 / (1 ** |y|)
  # so do test for negative $y after above's clause

  return $x->round(@r) if $x->is_zero();  # 0**y => 0 (if not y <= 0)

  # shortcut y/1 (and/or x/1)
  if ($MBI->_is_one($y->{_d}))
    {
    # shortcut for x/1 and y/1
    if ($MBI->_is_one($x->{_d}))
      {
      $x->{_n} = $MBI->_pow($x->{_n},$y->{_n});		# x/1 ** y/1 => (x ** y)/1
      if ($y->{sign} eq '-')
        {
        # 0.2 ** -3 => 1/(0.2 ** 3)
        ($x->{_n},$x->{_d}) = ($x->{_d},$x->{_n});	# swap
        }
      # correct sign; + ** + => +
      if ($x->{sign} eq '-')
        {
        # - * - => +, - * - * - => -
        $x->{sign} = '+' if $MBI->_is_even($y->{_n});	
        }
      return $x->round(@r);
      }
    # x/z ** y/1
    $x->{_n} = $MBI->_pow($x->{_n},$y->{_n});		# 5/2 ** y/1 => 5 ** y / 2 ** y
    $x->{_d} = $MBI->_pow($x->{_d},$y->{_n});
    if ($y->{sign} eq '-')
      {
      # 0.2 ** -3 => 1/(0.2 ** 3)
      ($x->{_n},$x->{_d}) = ($x->{_d},$x->{_n});	# swap
      }
    # correct sign; + ** + => +
    if ($x->{sign} eq '-')
      {
      # - * - => +, - * - * - => -
      $x->{sign} = '+' if $MBI->_is_even($y->{_n});	
      }
    return $x->round(@r);
    }

  # regular calculation (this is wrong for d/e ** f/g)
  my $pow2 = $self->bone();
  my $y1 = $MBI->_div ( $MBI->_copy($y->{_n}), $y->{_d});
  my $two = $MBI->_two();

  while (!$MBI->_is_one($y1))
    {
    $pow2->bmul($x) if $MBI->_is_odd($y1);
    $MBI->_div($y1, $two);
    $x->bmul($x);
    }
  $x->bmul($pow2) unless $pow2->is_one();