home *** CD-ROM | disk | FTP | other *** search
/ ftp.installgentoo.com/Dos_Games/ / Dos_Games.zip / Dos_Games / rpn.pas < prev    next >
Pascal/Delphi Source File  |  2012-11-30  |  13KB  |  381 lines
  1. {$N+,E+} { use software floating point }
  2. program rpn;
  3.  
  4. type CommandLineType = string[127];
  5.  
  6. var
  7.   x,y,z,t,tmp    :extended;  { change all "extended" to "extended" for more precision }
  8.   coms,com       :string;
  9.   CommandLinePtr : ^CommandLineType;
  10.   i,j,k,n        :integer;
  11.   anglemode,             { 0=radians, 1=degrees }
  12.   decimals,              { number of places to display }
  13.   dispmode       :byte;  { 0=fix, 1=sci, 2=eng, 3=fraction }
  14.   ok             :boolean;
  15.  
  16. function pow(number,exponent:extended):extended;
  17.   { implements Pascal's missing exponentiation function }
  18.   begin
  19.   if exponent=0.0 then pow:=1.0
  20.   else
  21.     if number=0.0 then pow:=0.0
  22.     else
  23.       if abs(exponent*Ln(abs(number))) > 11356.5 then
  24.         begin writeln ('Overflow in power expression'); end
  25.       else
  26.         if number>0.0 then pow:=Exp(exponent*Ln(number))
  27.         else
  28.           if (number<0.0) and (Frac(exponent)=0.0) then
  29.             if Odd(Round(exponent)) then pow:= -pow(-number, exponent)
  30.             else pow:=pow(-number, exponent)
  31.             else
  32.               begin writeln('Invalid power expression'); end;
  33.    end;  (* pow *)
  34.  
  35. procedure DisplayNumber(x:extended);
  36.   var n:extended; d,p:integer; s:char; st:string;
  37.   begin
  38.   d:=dispmode;
  39.   if (d=0) and (x<>0) then
  40.     if (Abs(x)<1/(Exp(decimals*Ln(10)))) then d:=2;
  41.   case d of
  42.     0: begin                   { fixed mode }
  43.        Str(x:0:decimals,st);
  44.        d:=Pos('.',st);
  45.        while d>4 do  { put commas in }
  46.          begin
  47.          st:=Copy(st,1,d-4) + ',' + Copy(st,d-3,200);
  48.          d:=d-3;
  49.          end;
  50.        writeln(st);
  51.        end;
  52.     1: writeln(x:decimals+9);  { scientific }
  53.     2: begin                   { engineering }
  54.        p:=0; n:=x;
  55.        while Abs(n)>=1000 do begin n:=n/1000; p:=p+3; end;
  56.        while (Abs(n)<1) and (n<>0.0) do begin n:=n*1000; p:=p-3; end;
  57.        if p>=0 then s:='+' else begin s:='-'; p:=-p; end;
  58.        writeln(n:0:decimals-Trunc(Abs(Ln(Abs(n)+0.003123234145))/Ln(10)),' E',s,p);
  59.        end;
  60.     3: begin                   { fractions }
  61.        x:=x + 0.0000000000000001;
  62.        d:=1 shl Decimals;  { d is largest denominator allowed }
  63.        if x>=0 then s:=' ' else s:='-'; x:=Abs(x);
  64.        { does it not have a fractional part, within d/2? }
  65.        if (Frac(x)+1/d/2>=1) or (Frac(x)-1/d/2<0) then begin writeln(s,Round(x):0); Exit; end;
  66.        write(s,x-Frac(x):0:0,' ');
  67.        { while the numerator is even, divide denom by two }
  68.        while ((Round(Frac(x)*d) mod 2)=0) and (d>2) do d:=d div 2;
  69.        writeln(Frac(x)*d:0:0,'/',d);
  70.        end;
  71.     end;
  72.   end;
  73.  
  74. procedure mult;
  75.   begin x:=x*y; y:=z; z:=t; end;
  76.  
  77. procedure divd;
  78.   begin x:=y/x; y:=z; z:=t; end;
  79.  
  80. procedure add;
  81.   begin x:=x+y; y:=z; z:=t; end;
  82.  
  83. procedure subt;
  84.   begin x:=y-x; y:=z; z:=t; end;
  85.  
  86. procedure perc;
  87.   begin x:=x*y/100; end;
  88.  
  89. procedure rolld;
  90.   begin tmp:=x; x:=y; y:=z; z:=t; t:=tmp; end;
  91.  
  92. procedure swap;
  93.   begin tmp:=x; x:=y; y:=tmp; end;
  94.  
  95. procedure expo;
  96.   begin x:=pow(y,x); y:=z; z:=t; end;
  97.  
  98. function csin(x:extended):extended;
  99.   begin  { my own sin function to work with degrees or radians }
  100.   if anglemode=1 then x:=x*pi/180;
  101.   csin:=sin(x);
  102.   end;
  103.  
  104. function ccos(x:extended):extended;
  105.   begin
  106.   if anglemode=1 then x:=x*pi/180;
  107.   ccos:=cos(x);
  108.   end;
  109.  
  110. function carctan(x:extended):extended;
  111.   begin
  112.   if anglemode=0 then carctan:=arctan(x) else carctan:=arctan(x)*180/pi;
  113.   end;
  114.  
  115. function fact(n:extended):extended;
  116.   var t:extended;
  117.   begin
  118.   if n>1754 then begin writeln('Error - overflow in factorial'); fact:=n; Exit; end;
  119.   t:=1;
  120.   while n>1 do begin t:=t*n; n:=n-1; end;
  121.   fact:=t;
  122.   end;
  123.  
  124. function perm(n,r:extended):extended;      { n! / (n-r)! }
  125.   var
  126.     t,i :extended;
  127.   begin
  128.   if r>n then begin perm:=0; Exit; end;
  129.   t:=1;
  130.   if n>r then
  131.     begin
  132.     i:=n;
  133.     while i>=(n-r+0.99) do
  134.       begin
  135.       t:=t*i;
  136.       i:=i-1;
  137.       end;
  138.     end;
  139.   perm:=t;
  140.   end;
  141.  
  142. function comb(n,r:extended ):extended;      { n! / (r!) (n-r)! }
  143.   var
  144.     t,i :extended;
  145.   begin
  146.   if r>n-r then r:=n-r;
  147.   if r>n then begin Comb:=0; Exit; end;
  148.   t:=1;
  149.   if n>r then
  150.     begin
  151.     i:=n;
  152.     while i>=(n-r+0.99) do
  153.       begin
  154.       t:=t*i;
  155.       i:=i-1;
  156.       end;
  157.     end;
  158.   comb:=t/fact(r);
  159.   end;
  160.  
  161. function ArcSin (x : extended) : extended;
  162.   var t:extended;
  163.   begin
  164.   if (x<-1.0) or (x>1.0) then begin writeln('ArcSin argument out of range [-1,1]'); Exit; end;
  165.     if x=1.0 then t:=pi/2
  166.     else if x=-1.0 then t:=-pi/2
  167.       else t:=ArcTan(x/Sqrt(1.0-Sqr(x)));
  168.   if anglemode=0 then arcsin:=t else arcsin:=t*180/pi;
  169.   end; (* arcsin *)
  170.  
  171. function ArcCos (x:extended):extended;
  172.   begin
  173.   if anglemode=0 then arccos:=pi/2 - arcsin(x) else arccos:=90-arcsin(x);
  174.   end; (* arccos *)
  175.  
  176. procedure GetDecimals; { gets the single digit after fix, sci, eng, or frac }
  177.   begin
  178.   if (Length(coms)>0) and (coms[1] in ['0'..'9']) then
  179.     begin
  180.     decimals:=Ord(coms[1])-Ord('0');
  181.     Delete(coms,1,1);
  182.     end;
  183.   end;
  184.  
  185. function gamma(x:extended):extended;
  186.   var i,j   :integer;
  187.       y,gam :extended;
  188.   begin      { gamma function }
  189.   gamma:=x;  { in case of error, use this value }
  190.   if (x<1.0) and (Frac(x)=0.0) then
  191.     begin
  192.     writeln('Error - overflow in gamma (integer < 1)');
  193.     Exit;
  194.     end;
  195.   if x>=0.0 then
  196.     begin
  197.     y:=x+2.0;
  198.     gam:=sqrt(2*pi/y)*exp(y*ln(y)+(1-1/(30*y*y))/(12*y)-y);
  199.     gamma:=gam/(x*(x+1))
  200.     end
  201.   else             { x<0 }
  202.     begin
  203.     j:=0;
  204.     y:=x;
  205.     repeat
  206.       j:=j+1;
  207.       y:=y+1.0
  208.     until y>0.0;
  209.     gam:=gamma(y);            { recursive call }
  210.     for i:=0 to j-1 do gam:=gam/(x+i);
  211.     gamma:=gam
  212.     end   { x<0 }
  213.   end;    { gamma function }
  214.  
  215. procedure help;
  216.   begin
  217.   writeln('example usage:',#13,#10,' rpn 10 15+2 3+/  => computes (10+15) / (2+3)');
  218.   writeln('use spaces to separate entry of numbers and spelled');
  219.   writeln(' operators, otherwise they are not needed.');
  220.   writeln('commands understood:');
  221.   writeln(' + - * / ^ => standard arithmetic operators');
  222.   writeln(' % => takes x% of y ( 100 15%- yields 85 )');
  223.   writeln(' c[hs] => change sign of x (minus key is for subtraction)');
  224.   writeln(' x, swap, r, roll => x-swap-y, rolldown');
  225.   writeln(' sin, cos, tan, asin, acos, atan, ln, exp, log => math functions');
  226.   writeln(' sqrt, inv, pi => square root, inverse (1/x), pi)');
  227.   writeln(' delta => computes delta percent from y to x');
  228.   writeln(' ? => use inside a calculation to diplay a result in the middle');
  229.   writeln(' stack => displays t, z, y, and x registers of stack');
  230.   writeln(' deg, rad => set degrees or radians mode for trig functions');
  231.   writeln(' comb, perm, !, gamma => combinations, permutations, factorial, gamma');
  232.   writeln(' fix[n] sci[n] eng[n] => fixed, sci, or eng, optional n is decimal places');
  233.   writeln(' frac[n] => display as fraction, with denominator at most 2^n');
  234.   writeln(' fractions: 90.1.8 => 90 1/8, 90.1.5.2 => 90 3/4 (1.5/2)');
  235.   writeln(' enter exponent: 6.02e23, 6.02e+23, or 1.3807e-23');
  236.   writeln(' q => quit');
  237.   end;
  238.  
  239.  
  240. begin
  241. dispmode:=0; decimals:=4; anglemode:=0;
  242. x:=0; y:=0; z:=0; t:=0;
  243.  
  244. CommandLinePtr := Ptr(PrefixSeg, $80);
  245. coms:=CommandLinePtr^;  { coms is the command string }
  246. for i:=1 to Length(coms) do coms[i]:=UpCase(coms[i]);
  247.  
  248. { if 'Q' was on command line, don't list this }
  249. if Pos('Q',coms)=0 then writeln('RPN calculator v1.24   Enter Q to quit   H for help');
  250.  
  251. repeat
  252.   if Length(coms)>0 then
  253.     begin
  254.     ok:=false;  { ok just checks that the command was understood }
  255.     case coms[1] of
  256.       '0'..'9','.':
  257.         begin
  258.         com:=''; j:=1;
  259.         while (length(coms)>0) and (coms[1] in ['0'..'9','.'])
  260.              or (Length(coms)>1) and (coms[1]='E') and (coms[2] in ['0'..'9','-','+'])  do
  261.           begin
  262.           com:=com+coms[1];
  263.           if (Length(coms)>1) and (coms[1]='E') and (coms[2] in ['+','-']) then
  264.             begin
  265.             if coms[2]='-' then j:=-1 else j:=1; { flag to make exponent minus }
  266.             Delete(coms,1,1);
  267.             end;
  268.           Delete(coms,1,1);
  269.           end; { while }
  270.         t:=z; z:=y; y:=x;
  271.         { does the number have an 'E' in it? }
  272.         if Pos('E',com)>0 then
  273.           begin
  274.           Val(Copy(com,1,Pos('E',com)-1),x,i);
  275.           Val(Copy(com,Pos('E',com)+1,100),tmp,i); tmp:=j*tmp;
  276.           x:=x * pow(10,tmp);
  277.           end
  278.         else
  279.           begin
  280.           { does this have more than one '.'? Input a fraction }
  281.           i:=Pos('.',com); j:=Pos('.',Copy(com,i+1,100))+i;
  282.           if j=i then val(com,x,i)
  283.           else
  284.             begin  { get the fraction: 90.1.8 = 90 1/8 }
  285.             while Pos('.',Copy(com,j+1,100))>0 do j:=Pos('.',Copy(com,j+1,100))+j; { j now holds pos of last dot }
  286.             Val(Copy(com,i+1,j-i-1),x,k); { get numerator of fraction }
  287.             Val(Copy(com,j+1,100),tmp,k); x:=x/tmp; { denominator }
  288.             Val(Copy(com,1,i-1),tmp,k); x:=tmp+x; { integer part }
  289.             end;
  290.           ok:=true;
  291.           end;
  292.         end; { numeric coms }
  293.       '+': begin Delete(coms,1,1); ok:=true; add; end;
  294.       '-': begin Delete(coms,1,1); ok:=true; subt; end;
  295.       '*': begin Delete(coms,1,1); ok:=true; mult; end;
  296.       '/': begin Delete(coms,1,1); ok:=true; if x<>0 then divd else writeln('Error - divide by zero'); end;
  297.       '^': begin Delete(coms,1,1); ok:=true; expo; end;
  298.       '%': begin Delete(coms,1,1); ok:=true; perc; end;
  299.       '?': begin Delete(coms,1,1); ok:=true; DisplayNumber(x); end;
  300.       '!': begin Delete(coms,1,1); ok:=true; x:=fact(x); end;
  301.       ' ': begin Delete(coms,1,1); ok:=true; end;
  302.  
  303.       { is it a letter? get the whole string }
  304.       'A'..'Z':
  305.         begin
  306.         {build the whole string }
  307.         com:='';
  308.         while (Length(coms)>0) and (coms[1] in ['A'..'Z']) do
  309.           begin
  310.           com:=com+coms[1];
  311.           Delete(coms,1,1);
  312.           end;
  313.         if (com='X') or (com='SWAP') then begin ok:=true; swap; end;
  314.         if (com='R') or (com='ROLL') then begin ok:=true; rolld; end;
  315.         if com='H' then begin ok:=true; help; end;
  316.         if com='SIN' then begin ok:=true; x:=csin(x); end;
  317.         if com='COS' then begin ok:=true; x:=ccos(x); end;
  318.         if com='TAN' then begin ok:=true; if ccos(x)<>0 then x:=csin(x)/ccos(x) else writeln('Error - overflow in tan'); end;
  319.         if com='ATAN' then begin ok:=true; x:=carctan(x); end;
  320.         if com='ASIN' then begin ok:=true; x:=arcsin(x); end;
  321.         if com='ACOS' then begin ok:=true;  x:=arccos(x); end;
  322.         if com='LN' then begin ok:=true; if x>0 then x:=ln(x) else writeln('Error - ln of negative number'); end;
  323.         if com='LOG' then begin ok:=true; if x>0 then x:=ln(x)/ln(10) else writeln('Error - log of negative number'); end;
  324.         if com='EXP' then begin ok:=true; if x<=11356 then x:=exp(x) else writeln('Error - overflow in exp'); end;
  325.         if com='SQRT' then begin ok:=true; if x>=0 then x:=sqrt(x) else writeln('Error - sqrt of negative number'); end;
  326.         if com='INV' then begin ok:=true; if x<>0 then x:=1/x else writeln ('Error - inverse of zero'); end;
  327.         if com='PI' then begin ok:=true; t:=z; z:=y; y:=x; x:=pi; end;
  328.         if com='COMB' then begin ok:=true; x:=comb(y,x); y:=z; z:=t; end;
  329.         if com='PERM' then begin ok:=true; x:=perm(y,x); y:=z; z:=t; end;
  330.         if com='GAMMA' then begin ok:=true; x:=Gamma(x); end;
  331.         if com='DEG' then begin ok:=true; anglemode:=1; end;
  332.         if com='RAD' then begin ok:=true; anglemode:=0; end;
  333.         if (com='C') or (com='CHS') then begin x:=-x; end;
  334.         if com='DELTA' then begin ok:=true; if y<>0 then begin x:=(x-y)/y*100; y:=z; z:=t; end
  335.                                             else writeln('Error - divide by zero in delta'); end;
  336.         if com='STACK' then
  337.           begin
  338.           ok:=true;
  339.           write('t: '); DisplayNumber(t);
  340.           write('z: '); DisplayNumber(z);
  341.           write('y: '); DisplayNumber(y); write('x: ');
  342.           end;
  343.         if com='FIX' then
  344.           begin
  345.           ok:=true; dispmode:=0;
  346.           GetDecimals;
  347.           end;
  348.         if com='SCI' then
  349.           begin
  350.           ok:=true; dispmode:=1;
  351.           GetDecimals;
  352.           end;
  353.         if com='ENG' then
  354.           begin
  355.           ok:=true; dispmode:=2;
  356.           GetDecimals;
  357.           end; { eng }
  358.         if com='FRAC' then
  359.           begin
  360.           ok:=true; dispmode:=3;
  361.           GetDecimals;
  362.           end; { frac }
  363.         if not ok then begin ok:=true; writeln('command not understood: ',com); end;
  364.         end;  { starts with a letter }
  365.       else Delete(coms,1,1);
  366.       end; { case }
  367.     if not ok then begin ok:=true; writeln('command not understood: ',coms[1]); end;
  368.     end
  369.   else
  370.     begin
  371.     DisplayNumber(x);
  372.     readln(coms);
  373.     for i:=1 to Length(coms) do coms[i]:=UpCase(coms[i]);
  374.     if coms[1]='Q' then com:='Q';
  375.  
  376.     end;
  377. until com='Q';
  378. DisplayNumber(x);
  379. end.
  380.  
  381.