home *** CD-ROM | disk | FTP | other *** search
/ Frostbyte's 1980s DOS Shareware Collection / floppyshareware.zip / floppyshareware / USCX / TURBO-09.ZIP / POWERS.PAS < prev    next >
Pascal/Delphi Source File  |  1985-05-28  |  4KB  |  145 lines
  1. { Turbo Pascal functions to compute Powers.
  2.   Original written by Paul F. Hultquist, published in PC Tech Journal,
  3.   Vol. 3, No. 5 (May '85), p.213.
  4.  
  5.   Additions and modifications by Roy Collins, 5/8/85:
  6.     * Error conditions caused the program to display an error message
  7.       and halt.  Changed to display error message, beep, and return
  8.       a value of zero.
  9.     * Since Paul stated that PWRI is faster than PWRR when raising a
  10.       real to an integer power, I added code to PWRR to check for an
  11.       'Y' value and to call PWRI when appropraitte.
  12.     * Added new testing procedures. }
  13.  
  14. procedure beep;
  15.     { Test use only.
  16.       Draw attention to error conditions. }
  17. begin
  18.   sound(1000); delay(150); nosound;
  19.   delay(100);
  20.   sound(2000); delay(150); nosound;
  21. end; (* proc beep *)
  22.  
  23. function pwri(x:real; n:integer):real;
  24.     { PWRI performs the tests necessary to eliminate non-computable cases
  25.       of finding X (real) to the power N (integer).  It calls upon function
  26.       RLSCAN to do the actual computation after it has, for example,
  27.       replaced a negative with a positive one (it does a reciprocation
  28.       after return from RLSCAN in that case. Error conditions return a
  29.       zero value. }
  30.  
  31.   function rlscan(x:real; n:integer):real;
  32.     { This function scans the positive exponent from right to left to
  33.       determine a sequence of multiplications and squarings that produce
  34.       X (real) to the power N (integer) in a near-minimum number of
  35.       multiplications. The algorithm is Algorithm A, p. 442, Vol. 2,
  36.       2nd Ed. of Knuth: "The Art of Computer Programming: Seminumerical
  37.       Algorithms", Addison-Wesley, 1981. }
  38.   var
  39.     y, z : real;
  40.     o    : boolean;
  41.     bign : integer;
  42.   begin
  43.     bign := n;
  44.     y := 1.0;
  45.     z := x;
  46.     while bign > 0 do begin
  47.       o := odd(bign);
  48.       bign := bign div 2;
  49.       if o then begin
  50.         y := y * z;
  51.         rlscan := y;
  52.         end;
  53.       z := z * z;
  54.       end;
  55.   end; (* func rlscan *)
  56.  
  57. begin
  58.   if n > 0 then
  59.     pwri := rlscan(x,n)
  60.   else
  61.   if (x <> 0.0) and (n < 0) then begin
  62.     n := -n;
  63.     pwri := 1.0 / rlscan(x,n);
  64.     end
  65.   else
  66.   if (n = 0) and (x <> 0) then
  67.     pwri := 1.0
  68.   else
  69.   if (n = 0) and (x = 0) then begin
  70.     writeln('0 to the 0 power.');
  71.     beep;
  72.     pwri := 0.0;
  73.     end
  74.   else
  75.   if (n < 0) and (x = 0) then begin
  76.     writeln('Division by zero.');
  77.     beep;
  78.     pwri := 0.0;
  79.     end;
  80. end; (* func pwri *)
  81.  
  82. function pwrr(x,y:real):real;
  83.     { PWRR finds X (real) to the power Y (real) using algorithms and
  84.       exponentials. If Y is an integer PWRI is faster.  The function
  85.       eliminates the undefined cases and the case where the result is
  86.       complex. For these error conditions, zero is returned. }
  87.     { Added by Roy Collins, 5/8/85:
  88.          Since PWRI is faster for cases where Y is an integer,
  89.          if Y is an acceptable integer, use PWRI to compute x**y }
  90. begin
  91.   if (y = int(y)) and (abs(y) <= 32767) then
  92.     pwrr := pwri(x,trunc(y))
  93.   else
  94.   if x > 0 then
  95.     pwrr := exp(y*ln(x))
  96.   else
  97.   if x < 0 then begin
  98.     writeln('X < 0.');
  99.     beep;
  100.     pwrr := 0.0;
  101.     end
  102.   else
  103.   if (x=0) and (y=0) then begin
  104.     writeln('0 to the 0 power.');
  105.     beep;
  106.     pwrr := 0.0;
  107.     end
  108.   else
  109.   if (x=0) and (y<0) then begin
  110.     writeln('0 ti a negative power.');
  111.     beep;
  112.     pwrr := 0.0;
  113.     end
  114.   else
  115.     pwrr := 0.0;
  116. end; (* func pwrr *)
  117.  
  118. var
  119.   ch : char;
  120.   x, y : real;
  121. begin (* test pwri and pwrr functions *)
  122.   repeat
  123.     writeln;
  124.     write('Test R)eal or I)nteger power function (or Q)uit)? (R/N/Q)');
  125.     repeat
  126.       read(kbd,ch);
  127.       ch := upcase(ch);
  128.     until ch in ['R','I','Q'];
  129.     if ch = 'Q' then
  130.       halt;
  131.     writeln(ch);
  132.     if ch = 'R' then
  133.       writeln('Raise X (real) to the Y (real) power')
  134.     else
  135.       writeln('Raise X (real) to the Y (integer) power');
  136.     write('Enter X value: ');
  137.     readln(x);
  138.     write('Enter Y value: ');
  139.     readln(y);
  140.     if ch = 'R' then
  141.       writeln('Real power = ',pwrr(x,y):12:11)
  142.     else
  143.       writeln('Integer power = ',int(pwri(x,trunc(y))):12:11);
  144.   until false;
  145. end.