home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / calculat / rpncalc.lbr / RPN2.PZS / RPN2.PAS
Pascal/Delphi Source File  |  1987-09-12  |  10KB  |  295 lines
  1. Program RPNCALC; { a HP-style reverse Polish notation calculator }
  2.  
  3. Type
  4.  String80 = String[80];
  5.  String40 = String[40];
  6.  Comlist = Array [1..20] of String40;
  7.  
  8. Const
  9.  Version = '87.0910'; Rnum = 9; { Rnum +1 storage locations }
  10.  MaxReal = 9.999999999999E+37;
  11.  
  12. Var
  13.   X,Y,Z,T,T2,Value: Real; { the HP stack }
  14.   LstX: Real;      { last x }
  15.   R: Array [0..Rnum] of Real;  { ten storage locations }
  16.   Done: Boolean;
  17.   ComNum,IntVal,Fix,Trigmode: Integer;
  18.        { Trigmode = 0 radians, 1 degrees, 2 grads }
  19.   Command: Comlist;
  20.   ComString: String80;
  21.   Numerical,Alpha,Sign,Op: Set of Char;
  22.   ComChar,Sp:String[1];
  23.  
  24. Function DtoR(X:Real):Real;  { degrees -> radians }
  25. Begin
  26.  DtoR:=X*Pi/180.0
  27. End;
  28.  
  29. Function RtoD(X:Real):Real;  { radians -> degrees }
  30. Begin
  31.  RtoD:=X*180.0/Pi
  32. End;
  33.  
  34. Function GtoR(X:Real):Real;  { grads -> radians }
  35. Begin
  36.  GtoR:=X*Pi/200.0
  37. End;
  38.  
  39. Function RtoG(X:Real):Real;  { radians -> grads }
  40. Begin
  41.  RtoG:=X*200.0/Pi
  42. End;
  43.  
  44. Function Tan(X:Real):Real;
  45. Begin
  46.  If Abs(X) < 1E-11 then Tan:=0.0 else Tan:=Sin(X)/Cos(X)
  47. End;
  48.  
  49. Function Asin(X:Real):Real;
  50. Begin
  51.   If Abs(X)=1 then Asin:=X*Pi/2 else
  52.       Asin:= Arctan(X/Sqrt(1.0-X*X))
  53. End;
  54.  
  55. Function Acos(X:Real):Real;
  56. Begin
  57.   If X=0 then Acos:=Pi/2.0 else
  58.      If X=-1 then Acos:=Pi else
  59.       If X>=0 then Acos:=Arctan(Sqrt(1.0-Sqr(X))/X) else
  60.          Acos:=Pi + Arctan(Sqrt(1.0-Sqr(X))/X)
  61. End;
  62.  
  63. Function Log(X:Real):Real;
  64. Begin
  65.  Log:=Ln(X)/Ln(10.0)
  66. End;
  67.  
  68. Function Pwr(Exponent,Base:Real):Real;
  69. Begin
  70.   Pwr:=Exp(Exponent*Ln(Base))
  71. End;
  72.  
  73. Procedure TrigCycle(Var X:Real); { alias X into -2Pi to 2Pi }
  74. Begin
  75.  Case Trigmode of
  76.   0:  X:=(X/2.0/Pi-Trunc(X/2.0/Pi))*2.0*Pi;                    {radians}
  77.   1:  Begin X:=(X/360.0-Trunc(X/360.0))*360.0; X:=DtoR(X) End; {degrees}
  78.   2:  Begin X:=(X/400.0-Trunc(X/400.0))*400.0; X:=GtoR(X) End; {grads}
  79.  End; { end case }
  80. End;
  81.  
  82. Procedure Help_Menu;
  83.  Begin
  84.   Writeln;
  85.   Writeln('RPN (HP-style) Calculator Program   Version: ',Version);
  86.   Writeln('Copyright (C) 1987             by C. Scott Blackwell'); Writeln;
  87.   Writeln('Works like a RPN calculator;  Functions supported are :');
  88.   Writeln('HELP or ?  -> This screen.  ');
  89.   Writeln(' +, -, /, *, ENTER <CR>, STK, FIX I, FLOAT, LOG, ALOG, LN, EXP');
  90.   Writeln('X**Y, STO I, RCL I, INT, FRAC, SQR, SQRT, EX (X<->Y), PI, DONE');
  91.   Writeln('RAD, DEG, GRAD, SIN, COS, TAN, ASIN, ACOS, ATAN');
  92.   Writeln('RUP, RDOWN, R (1/X), MEM (show memories) '); Writeln;
  93.   Writeln('Enter a number and <CR> to ENTER and raise the stack');
  94.   Writeln('A number followed by a space and a legal command will execute');
  95.   Writeln(
  96.     'the operation on the number and the result replaces X');
  97.   Writeln('You can string up to 20 commands and numbers before a <CR>');
  98.   Writeln;
  99.   Writeln('There are currently ',Rnum+1:0,' addressable memory locations');
  100.   Writeln('     numbered 0 to ',Rnum); Writeln
  101. End;
  102.  
  103. Procedure Initialize;
  104.  
  105. Var
  106.   I: Integer;
  107.  
  108.  Begin
  109.   X:=0.0; Y:=0.0; Z:=0.0; T:=0.0; LstX:=0.0; IntVal:=-1;
  110.   Value:=0.0;  Fix:=2; Trigmode:=1;
  111.   Numerical:=['0'..'9','.'];
  112.   Alpha:=['A'..'Z','a'..'z']; Sign:=['+','-']; Op:=Sign + ['*','/'];
  113.   For I:=0 to 9 Do R[I]:=0.0; Sp:=' ';
  114.  End;
  115.  
  116. Procedure Parse(Var ComString:String80; Var Command:Comlist;
  117.                 Var ComNum:Integer);
  118.  
  119. Var
  120.  Lstart,Sep,Lcom,I,K: Integer;
  121.  Done: Boolean;
  122.  Error:Integer;
  123.  
  124. Begin
  125.  ComNum:=0; Lstart:=Length(ComString);
  126.  
  127.   { separate out and count commands stringed and separated by spaces
  128.      remember signs are not legal on numbers -- Use CHS to get negatives!}
  129.  
  130.  Repeat
  131.   ComNum:=Comnum+1;
  132.   Sep:=Pos(Sp,ComString); Lcom:=Length(ComString);
  133.   If Lstart=0 then Command[ComNum]:='ENTER';
  134.   If (Sep>0) then Begin
  135.       Command[ComNum]:=Copy(ComString,1,Sep-1);
  136.       Delete(ComString,1,Sep) End  { remove first command or number }
  137.      else Begin
  138.       If Lcom<>0 then Command[ComNum]:=ComString End;
  139.  Until (Sep=0) or (Comnum=20);
  140.  If (Comnum=20) and (Pos(Sp,ComString)>0) then
  141.      Writeln(Chr(7),'ERROR -- more than 20 commands and numbers!!');
  142.  For I:=1 to ComNum Do
  143.    For K:=1 to Length(Command[I]) Do
  144.         Command[I][K]:=UpCase(Command[I][K]);
  145. End;
  146.  
  147. Procedure WriteStack;
  148. Begin
  149.  Writeln('T ',T); Writeln('Z ',Z); Writeln('Y ',Y); Writeln('X ',X)
  150. End;
  151.  
  152. { Note: extra element T2 added to stack to permit string of commands
  153.   in the input command string }
  154.  
  155. Procedure Raise_Stack;
  156. Begin T2:=T; T:=Z; Z:=Y; Y:=X; End;
  157.  
  158. Procedure Lower_Stack;
  159. Begin X:=Y; Y:=Z; Z:=T; T:=T2; T2:=0.0; End;
  160.  
  161. Procedure Execute;
  162.  
  163. Var
  164.   Temp: Real;
  165.   I,II,ComFlag,Error: Integer;
  166.   Test1:Char;
  167.  
  168. Begin
  169.  I:=1; ComFlag:=1;
  170.  Repeat
  171.  
  172.        { the logic from here to HELP is crucial to handling the stack }
  173.  
  174.   Value:=X; Test1:=Command[I][1];
  175.   If (ComFlag=1) then
  176.      If Test1 in Numerical then Begin
  177.         If ComNum>0 then Begin
  178.           Val(Command[I],Value,Error); Raise_Stack;
  179.           X:=Value End;
  180.         If I=ComNum then Command[I]:='ENTER'
  181.       End;
  182.  
  183.   If (Command[I] = 'HELP') or (Command[I] = '?') then
  184.       Help_Menu;
  185.   If (Command[I] = 'ENTER') then
  186.      Begin
  187.        LstX:=X; Raise_Stack; X:=LstX;
  188.      End;
  189.   If (Command[I] = '*') then Begin
  190.               LstX:=X; Y:=X*Y;  Lower_Stack End;
  191.   If (Command[I] = '/') then Begin
  192.               LstX:=X; Y:=Y/X;  Lower_Stack End;
  193.   If (Command[I] = '+') then Begin
  194.               LstX:=X; Y:=Y+X; Lower_Stack End;
  195.   If (Command[I] = '-') then Begin
  196.               LstX:=X; Y:=Y-X; Lower_Stack End;
  197.   If (Command[I] = 'SQR') then Begin LstX:=X; X:=X*X End;
  198.   If (Command[I] = 'SQRT') then Begin
  199.         LstX:=X; X:=Sqrt(X) End;
  200.   If (Command[I] = 'STK') then Begin WriteStack End;
  201.   If (Command[I] = 'LSTX') then Begin Raise_Stack; X:=LstX End;
  202.   If (Command[I] = 'EXP') then Begin LstX:=X; X:=Exp(X) End;
  203.   If (Command[I] = 'LN') then Begin LstX:=X; X:=Ln(X) End;
  204.   If (Command[I] = 'LOG') then Begin LstX:=X; X:=Log(X) End;
  205.   If (Command[I] = 'R') then Begin LstX:=X; X:=1/X End;
  206.   If (Command[I] = 'INT') then Begin LstX:=X; X:=Trunc(X) End;
  207.   If (Command[I] = 'FRAC') then Begin LstX:=X; X:= X-Trunc(X) End;
  208.   If (Command[I] = 'RAD') then Trigmode:=0;
  209.   If (Command[I] = 'DEG') then Trigmode:=1;
  210.   If (Command[I] = 'GRAD') then Trigmode:=2;
  211.   If (Command[I] = 'SIN') then
  212.             Begin LstX:=X; TrigCycle(X); X:=Sin(X) End;
  213.   If (Command[I] = 'COS') then
  214.             Begin LstX:=X; TrigCycle(X); X:=Cos(X) End;
  215.   If (Command[I] = 'TAN') then Begin LstX:=X; TrigCycle(X);
  216.     If ((Pi/2.0 - Abs(X)) > 1.0E-35) then X:=Tan(X) else X:=MaxReal
  217.    End;
  218.   If (Command[I] = 'ATAN') then Begin LstX:=X;
  219.     Case Trigmode of
  220.       0 :  X:=Arctan(X);
  221.       1 :  X:=RtoD(Arctan(X));
  222.       2 :  X:=RtoG(Arctan(X));
  223.      End  { end case }
  224.    End;
  225.   If (Command[I] = 'ACOS') then Begin LstX:=X;
  226.    If Abs(X)>1.0 then Writeln(#7,'Error, sin or cos Out of Range!')
  227.     else
  228.     Case Trigmode of
  229.       0 :  X:=Acos(X);
  230.       1 :  X:=RtoD(Acos(X));
  231.       2 :  X:=RtoG(Acos(X));
  232.      End  { end case }
  233.    End;
  234.   If (Command[I] = 'ASIN') then Begin LstX:=X;
  235.    If Abs(X)>1.0 then Writeln(#7,'Error, sin or cos Out of Range!')
  236.     else
  237.     Case Trigmode of
  238.       0 :  X:=Asin(X);
  239.       1 :  X:=RtoD(Asin(X));
  240.       2 :  X:=RtoG(Asin(X));
  241.      End  { end case }
  242.    End;
  243.   IF (Command[I] = 'FIX') then Begin Comflag:=2;
  244.      Val(Command[I+1],Intval,Error); Fix:=IntVal End;
  245.   If (Command[I] = 'FLOAT') then Fix:=-1;
  246.   If (Command[I] = 'RUP') then Begin
  247.        Temp:=T; Raise_Stack; X:=Temp End;
  248.   If (Command[I] = 'RDOWN') then Begin
  249.        Temp:=X; Lower_Stack; T:=Temp End;
  250.   If (Command[I] = 'CHS') then Begin X:=-X End;
  251.   If (Command[I] = 'STO') then Begin
  252.      ComChar := Command[I+1][1];
  253.      If ComChar[1] in Numerical then Begin
  254.        Val(Command[I+1],Intval,Error); ComFlag:=2 End
  255.       else If ComChar[1] in Op then Begin
  256.         ComFlag:=3; Val(Command[I+2],Intval,Error) End;
  257.      If Intval in [0..Rnum] then
  258.        If ComFlag=2 then R[Intval]:=X else Begin
  259.           If Comchar = '+' then R[Intval]:=R[Intval] + X;
  260.           If ComChar = '-' then R[Intval]:=R[Intval] - X;
  261.           If ComChar = '*' then R[Intval]:=R[Intval]*X;
  262.           If ComChar = '/' then R[Intval]:=R[Intval]/X End
  263.          else Writeln('Error! Only 0 to ',Rnum:0,' memories')
  264.       End;
  265.   If (Command[I] = 'RCL') then Begin
  266.       ComFlag:=2; Val(Command[I+1],Intval,Error);
  267.       If Intval in [0..Rnum] then Begin Raise_Stack; X:=R[Intval] End
  268.        else Writeln('Error! Only 0 to ',Rnum:0,' memories') End;
  269.   If (Command[I] = 'ALOG') then Begin LstX:=X; X:=Pwr(X,10.0) End;
  270.   If (Command[I] = 'PI') then Begin LstX:=X; Raise_Stack; X:=Pi End;
  271.   If (Command[I] = 'X**Y') then Begin Y:=Pwr(Y,X); Lower_Stack End;
  272.   If (Command[I] = 'EX') then Begin Temp:=Y; Y:=X; X:=Temp End;
  273.   If (Command[I] = 'MEM') then Begin
  274.      For II:=Rnum Downto 0 Do Writeln('R[',II:0,']= ',R[II]) End;
  275.  
  276.    I:=I + Comflag;       { advance along command string proper number }
  277.    Comflag:=1;           { reset to default comflag }
  278.  Until (I= 1 + Comnum);
  279.   Value:=X;
  280.   If Fix >= 0 then Writeln('X: ',X:2:Fix)
  281.          else Writeln('X: ',X);
  282. End;
  283.  
  284. Begin
  285.  Writeln('Reverse Polish Notation Calculator    Version: ',Version);
  286.  Writeln('Copyright (C) 1987                  C. Scott Blackwell');
  287.  Initialize;
  288.  Repeat
  289.    Write('X:? '); Readln(ComString);
  290.    Parse(ComString,Command,ComNum);
  291.    Execute; X:=Value;
  292.    If Command[Comnum]='DONE' then Done:=True else Done:=False
  293.  Until Done
  294. End.
  295.