lib/bigfloat.pl

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