home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 11 Util / 11-Util.zip / unixtool.zip / TOOLS / lib / perl / bigfloat.pl < prev    next >
Perl Script  |  2000-04-21  |  7KB  |  234 lines
  1. package bigfloat;
  2. require "bigint.pl";
  3. # Arbitrary length float math package
  4. #
  5. # by Mark Biggar
  6. #
  7. # number format
  8. #   canonical strings have the form /[+-]\d+E[+-]\d+/
  9. #   Input values can have inbedded whitespace
  10. # Error returns
  11. #   'NaN'           An input parameter was "Not a Number" or 
  12. #                       divide by zero or sqrt of negative number
  13. # Division is computed to 
  14. #   max($div_scale,length(dividend).length(divisor)) 
  15. #   digits by default.
  16. # Also used for default sqrt scale
  17.  
  18. $div_scale = 40;
  19.  
  20. # Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
  21.  
  22. $rnd_mode = 'even';
  23.  
  24. #   bigfloat routines
  25. #
  26. #   fadd(NSTR, NSTR) return NSTR            addition
  27. #   fsub(NSTR, NSTR) return NSTR            subtraction
  28. #   fmul(NSTR, NSTR) return NSTR            multiplication
  29. #   fdiv(NSTR, NSTR[,SCALE]) returns NSTR   division to SCALE places
  30. #   fneg(NSTR) return NSTR                  negation
  31. #   fabs(NSTR) return NSTR                  absolute value
  32. #   fcmp(NSTR,NSTR) return CODE             compare undef,<0,=0,>0
  33. #   fround(NSTR, SCALE) return NSTR         round to SCALE digits
  34. #   ffround(NSTR, SCALE) return NSTR        round at SCALEth place
  35. #   fnorm(NSTR) return (NSTR)               normalize
  36. #   fsqrt(NSTR[, SCALE]) return NSTR        sqrt to SCALE places
  37.  
  38. # Convert a number to canonical string form.
  39. #   Takes something that looks like a number and converts it to
  40. #   the form /^[+-]\d+E[+-]\d+$/.
  41. sub main'fnorm { #(string) return fnum_str
  42.     local($_) = @_;
  43.     s/\s+//g;                               # strip white space
  44.     if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') {
  45.     &norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6));
  46.     } else {
  47.     'NaN';
  48.     }
  49. }
  50.  
  51. # normalize number -- for internal use
  52. sub norm { #(mantissa, exponent) return fnum_str
  53.     local($_, $exp) = @_;
  54.     if ($_ eq 'NaN') {
  55.     'NaN';
  56.     } else {
  57.     s/^([+-])0+/$1/;                        # strip leading zeros
  58.     if (length($_) == 1) {
  59.         '+0E+0';
  60.     } else {
  61.         $exp += length($1) if (s/(0+)$//);  # strip trailing zeros
  62.         sprintf("%sE%+ld", $_, $exp);
  63.     }
  64.     }
  65. }
  66.  
  67. # negation
  68. sub main'fneg { #(fnum_str) return fnum_str
  69.     local($_) = &'fnorm($_[0]);
  70.     vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign
  71.     s/^H/N/;
  72.     $_;
  73. }
  74.  
  75. # absolute value
  76. sub main'fabs { #(fnum_str) return fnum_str
  77.     local($_) = &'fnorm($_[0]);
  78.     s/^-/+/;                               # mash sign
  79.     $_;
  80. }
  81.  
  82. # multiplication
  83. sub main'fmul { #(fnum_str, fnum_str) return fnum_str
  84.     local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
  85.     if ($x eq 'NaN' || $y eq 'NaN') {
  86.     'NaN';
  87.     } else {
  88.     local($xm,$xe) = split('E',$x);
  89.     local($ym,$ye) = split('E',$y);
  90.     &norm(&'bmul($xm,$ym),$xe+$ye);
  91.     }
  92. }
  93.  
  94. # addition
  95. sub main'fadd { #(fnum_str, fnum_str) return fnum_str
  96.     local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
  97.     if ($x eq 'NaN' || $y eq 'NaN') {
  98.     'NaN';
  99.     } else {
  100.     local($xm,$xe) = split('E',$x);
  101.     local($ym,$ye) = split('E',$y);
  102.     ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
  103.     &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye);
  104.     }
  105. }
  106.  
  107. # subtraction
  108. sub main'fsub { #(fnum_str, fnum_str) return fnum_str
  109.     &'fadd($_[0],&'fneg($_[1]));    
  110. }
  111.  
  112. # division
  113. #   args are dividend, divisor, scale (optional)
  114. #   result has at most max(scale, length(dividend), length(divisor)) digits
  115. sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
  116. {
  117.     local($x,$y,$scale) = (&'fnorm($_[0]),&'fnorm($_[1]),$_[2]);
  118.     if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
  119.     'NaN';
  120.     } else {
  121.     local($xm,$xe) = split('E',$x);
  122.     local($ym,$ye) = split('E',$y);
  123.     $scale = $div_scale if (!$scale);
  124.     $scale = length($xm)-1 if (length($xm)-1 > $scale);
  125.     $scale = length($ym)-1 if (length($ym)-1 > $scale);
  126.     $scale = $scale + length($ym) - length($xm);
  127.     &norm(&round(&'bdiv($xm.('0' x $scale),$ym),$ym),
  128.         $xe-$ye-$scale);
  129.     }
  130. }
  131.  
  132. # round int $q based on fraction $r/$base using $rnd_mode
  133. sub round { #(int_str, int_str, int_str) return int_str
  134.     local($q,$r,$base) = @_;
  135.     if ($q eq 'NaN' || $r eq 'NaN') {
  136.     'NaN';
  137.     } elsif ($rnd_mode eq 'trunc') {
  138.     $q;                         # just truncate
  139.     } else {
  140.     local($cmp) = &'bcmp(&'bmul($r,'+2'),$base);
  141.     if ( $cmp < 0 ||
  142.          ($cmp == 0 &&
  143.           ( $rnd_mode eq 'zero'                             ||
  144.            ($rnd_mode eq '-inf' && (substr($q,0,1) eq '+')) ||
  145.            ($rnd_mode eq '+inf' && (substr($q,0,1) eq '-')) ||
  146.            ($rnd_mode eq 'even' && $q =~ /[24680]$/)        ||
  147.            ($rnd_mode eq 'odd'  && $q =~ /[13579]$/)        )) ) {
  148.         $q;                     # round down
  149.     } else {
  150.         &'badd($q, ((substr($q,0,1) eq '-') ? '-1' : '+1'));
  151.                     # round up
  152.     }
  153.     }
  154. }
  155.  
  156. # round the mantissa of $x to $scale digits
  157. sub main'fround { #(fnum_str, scale) return fnum_str
  158.     local($x,$scale) = (&'fnorm($_[0]),$_[1]);
  159.     if ($x eq 'NaN' || $scale <= 0) {
  160.     $x;
  161.     } else {
  162.     local($xm,$xe) = split('E',$x);
  163.     if (length($xm)-1 <= $scale) {
  164.         $x;
  165.     } else {
  166.         &norm(&round(substr($xm,0,$scale+1),
  167.              "+0".substr($xm,$scale+1,1),"+10"),
  168.           $xe+length($xm)-$scale-1);
  169.     }
  170.     }
  171. }
  172.  
  173. # round $x at the 10 to the $scale digit place
  174. sub main'ffround { #(fnum_str, scale) return fnum_str
  175.     local($x,$scale) = (&'fnorm($_[0]),$_[1]);
  176.     if ($x eq 'NaN') {
  177.     'NaN';
  178.     } else {
  179.     local($xm,$xe) = split('E',$x);
  180.     if ($xe >= $scale) {
  181.         $x;
  182.     } else {
  183.         $xe = length($xm)+$xe-$scale;
  184.         if ($xe < 1) {
  185.         '+0E+0';
  186.         } elsif ($xe == 1) {
  187.         &norm(&round('+0',"+0".substr($xm,1,1),"+10"), $scale);
  188.         } else {
  189.         &norm(&round(substr($xm,0,$trunc),
  190.               "+0".substr($xm,$trunc,1),"+10"), $scale);
  191.         }
  192.     }
  193.     }
  194. }
  195.     
  196. # compare 2 values returns one of undef, <0, =0, >0
  197. #   returns undef if either or both input value are not numbers
  198. sub main'fcmp #(fnum_str, fnum_str) return cond_code
  199. {
  200.     local($x, $y) = (&'fnorm($_[0]),&'fnorm($_[1]));
  201.     if ($x eq "NaN" || $y eq "NaN") {
  202.     undef;
  203.     } else {
  204.     ord($y) <=> ord($x)
  205.     ||
  206.     (  local($xm,$xe,$ym,$ye) = split('E', $x."E$y"),
  207.          (($xe <=> $ye) * (substr($x,0,1).'1')
  208.              || &bigint'cmp($xm,$ym))
  209.     );
  210.     }
  211. }
  212.  
  213. # square root by Newtons method.
  214. sub main'fsqrt { #(fnum_str[, scale]) return fnum_str
  215.     local($x, $scale) = (&'fnorm($_[0]), $_[1]);
  216.     if ($x eq 'NaN' || $x =~ /^-/) {
  217.     'NaN';
  218.     } elsif ($x eq '+0E+0') {
  219.     '+0E+0';
  220.     } else {
  221.     local($xm, $xe) = split('E',$x);
  222.     $scale = $div_scale if (!$scale);
  223.     $scale = length($xm)-1 if ($scale < length($xm)-1);
  224.     local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
  225.     while ($gs < 2*$scale) {
  226.         $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5");
  227.         $gs *= 2;
  228.     }
  229.     &'fround($guess, $scale);
  230.     }
  231. }
  232.  
  233. 1;
  234.