Program RPNCALC; { a HP-style reverse Polish notation calculator }

Type
 String80 = String[80];
 String40 = String[40];
 Comlist = Array [1..20] of String40;

Const
 Version = '87.0910'; Rnum = 9; { Rnum +1 storage locations }
 MaxReal = 9.999999999999E+37;

Var
  X,Y,Z,T,T2,Value: Real; { the HP stack }
  LstX: Real;      { last x }
  R: Array [0..Rnum] of Real;  { ten storage locations }
  Done: Boolean;
  ComNum,IntVal,Fix,Trigmode: Integer;
       { Trigmode = 0 radians, 1 degrees, 2 grads }
  Command: Comlist;
  ComString: String80;
  Numerical,Alpha,Sign,Op: Set of Char;
  ComChar,Sp:String[1];

Function DtoR(X:Real):Real;  { degrees -> radians }
Begin
 DtoR:=X*Pi/180.0
End;

Function RtoD(X:Real):Real;  { radians -> degrees }
Begin
 RtoD:=X*180.0/Pi
End;

Function GtoR(X:Real):Real;  { grads -> radians }
Begin
 GtoR:=X*Pi/200.0
End;

Function RtoG(X:Real):Real;  { radians -> grads }
Begin
 RtoG:=X*200.0/Pi
End;

Function Tan(X:Real):Real;
Begin
 If Abs(X) < 1E-11 then Tan:=0.0 else Tan:=Sin(X)/Cos(X)
End;

Function Asin(X:Real):Real;
Begin
  If Abs(X)=1 then Asin:=X*Pi/2 else
      Asin:= Arctan(X/Sqrt(1.0-X*X))
End;

Function Acos(X:Real):Real;
Begin
  If X=0 then Acos:=Pi/2.0 else
     If X=-1 then Acos:=Pi else
      If X>=0 then Acos:=Arctan(Sqrt(1.0-Sqr(X))/X) else
         Acos:=Pi + Arctan(Sqrt(1.0-Sqr(X))/X)
End;

Function Log(X:Real):Real;
Begin
 Log:=Ln(X)/Ln(10.0)
End;

Function Pwr(Exponent,Base:Real):Real;
Begin
  Pwr:=Exp(Exponent*Ln(Base))
End;

Procedure TrigCycle(Var X:Real); { alias X into -2Pi to 2Pi }
Begin
 Case Trigmode of
  0:  X:=(X/2.0/Pi-Trunc(X/2.0/Pi))*2.0*Pi;                    {radians}
  1:  Begin X:=(X/360.0-Trunc(X/360.0))*360.0; X:=DtoR(X) End; {degrees}
  2:  Begin X:=(X/400.0-Trunc(X/400.0))*400.0; X:=GtoR(X) End; {grads}
 End; { end case }
End;

Procedure Help_Menu;
 Begin
  Writeln;
  Writeln('RPN (HP-style) Calculator Program   Version: ',Version);
  Writeln('Copyright (C) 1987             by C. Scott Blackwell'); Writeln;
  Writeln('Works like a RPN calculator;  Functions supported are :');
  Writeln('HELP or ?  -> This screen.  ');
  Writeln(' +, -, /, *, ENTER <CR>, STK, FIX I, FLOAT, LOG, ALOG, LN, EXP');
  Writeln('X**Y, STO I, RCL I, INT, FRAC, SQR, SQRT, EX (X<->Y), PI, DONE');
  Writeln('RAD, DEG, GRAD, SIN, COS, TAN, ASIN, ACOS, ATAN');
  Writeln('RUP, RDOWN, R (1/X), MEM (show memories) '); Writeln;
  Writeln('Enter a number and <CR> to ENTER and raise the stack');
  Writeln('A number followed by a space and a legal command will execute');
  Writeln(
    'the operation on the number and the result replaces X');
  Writeln('You can string up to 20 commands and numbers before a <CR>');
  Writeln;
  Writeln('There are currently ',Rnum+1:0,' addressable memory locations');
  Writeln('     numbered 0 to ',Rnum); Writeln
End;

Procedure Initialize;

Var
  I: Integer;

 Begin
  X:=0.0; Y:=0.0; Z:=0.0; T:=0.0; LstX:=0.0; IntVal:=-1;
  Value:=0.0;  Fix:=2; Trigmode:=1;
  Numerical:=['0'..'9','.'];
  Alpha:=['A'..'Z','a'..'z']; Sign:=['+','-']; Op:=Sign + ['*','/'];
  For I:=0 to 9 Do R[I]:=0.0; Sp:=' ';
 End;

Procedure Parse(Var ComString:String80; Var Command:Comlist;
                Var ComNum:Integer);

Var
 Lstart,Sep,Lcom,I,K: Integer;
 Done: Boolean;
 Error:Integer;

Begin
 ComNum:=0; Lstart:=Length(ComString);

  { separate out and count commands stringed and separated by spaces
     remember signs are not legal on numbers -- Use CHS to get negatives!}

 Repeat
  ComNum:=Comnum+1;
  Sep:=Pos(Sp,ComString); Lcom:=Length(ComString);
  If Lstart=0 then Command[ComNum]:='ENTER';
  If (Sep>0) then Begin
      Command[ComNum]:=Copy(ComString,1,Sep-1);
      Delete(ComString,1,Sep) End  { remove first command or number }
     else Begin
      If Lcom<>0 then Command[ComNum]:=ComString End;
 Until (Sep=0) or (Comnum=20);
 If (Comnum=20) and (Pos(Sp,ComString)>0) then
     Writeln(Chr(7),'ERROR -- more than 20 commands and numbers!!');
 For I:=1 to ComNum Do
   For K:=1 to Length(Command[I]) Do
        Command[I][K]:=UpCase(Command[I][K]);
End;

Procedure WriteStack;
Begin
 Writeln('T ',T); Writeln('Z ',Z); Writeln('Y ',Y); Writeln('X ',X)
End;

{ Note: extra element T2 added to stack to permit string of commands
  in the input command string }

Procedure Raise_Stack;
Begin T2:=T; T:=Z; Z:=Y; Y:=X; End;

Procedure Lower_Stack;
Begin X:=Y; Y:=Z; Z:=T; T:=T2; T2:=0.0; End;

Procedure Execute;

Var
  Temp: Real;
  I,II,ComFlag,Error: Integer;
  Test1:Char;

Begin
 I:=1; ComFlag:=1;
 Repeat

       { the logic from here to HELP is crucial to handling the stack }

  Value:=X; Test1:=Command[I][1];
  If (ComFlag=1) then
     If Test1 in Numerical then Begin
        If ComNum>0 then Begin
          Val(Command[I],Value,Error); Raise_Stack;
          X:=Value End;
        If I=ComNum then Command[I]:='ENTER'
      End;

  If (Command[I] = 'HELP') or (Command[I] = '?') then
      Help_Menu;
  If (Command[I] = 'ENTER') then
     Begin
       LstX:=X; Raise_Stack; X:=LstX;
     End;
  If (Command[I] = '*') then Begin
              LstX:=X; Y:=X*Y;  Lower_Stack End;
  If (Command[I] = '/') then Begin
              LstX:=X; Y:=Y/X;  Lower_Stack End;
  If (Command[I] = '+') then Begin
              LstX:=X; Y:=Y+X; Lower_Stack End;
  If (Command[I] = '-') then Begin
              LstX:=X; Y:=Y-X; Lower_Stack End;
  If (Command[I] = 'SQR') then Begin LstX:=X; X:=X*X End;
  If (Command[I] = 'SQRT') then Begin
        LstX:=X; X:=Sqrt(X) End;
  If (Command[I] = 'STK') then Begin WriteStack End;
  If (Command[I] = 'LSTX') then Begin Raise_Stack; X:=LstX End;
  If (Command[I] = 'EXP') then Begin LstX:=X; X:=Exp(X) End;
  If (Command[I] = 'LN') then Begin LstX:=X; X:=Ln(X) End;
  If (Command[I] = 'LOG') then Begin LstX:=X; X:=Log(X) End;
  If (Command[I] = 'R') then Begin LstX:=X; X:=1/X End;
  If (Command[I] = 'INT') then Begin LstX:=X; X:=Trunc(X) End;
  If (Command[I] = 'FRAC') then Begin LstX:=X; X:= X-Trunc(X) End;
  If (Command[I] = 'RAD') then Trigmode:=0;
  If (Command[I] = 'DEG') then Trigmode:=1;
  If (Command[I] = 'GRAD') then Trigmode:=2;
  If (Command[I] = 'SIN') then
            Begin LstX:=X; TrigCycle(X); X:=Sin(X) End;
  If (Command[I] = 'COS') then
            Begin LstX:=X; TrigCycle(X); X:=Cos(X) End;
  If (Command[I] = 'TAN') then Begin LstX:=X; TrigCycle(X);
    If ((Pi/2.0 - Abs(X)) > 1.0E-35) then X:=Tan(X) else X:=MaxReal
   End;
  If (Command[I] = 'ATAN') then Begin LstX:=X;
    Case Trigmode of
      0 :  X:=Arctan(X);
      1 :  X:=RtoD(Arctan(X));
      2 :  X:=RtoG(Arctan(X));
     End  { end case }
   End;
  If (Command[I] = 'ACOS') then Begin LstX:=X;
   If Abs(X)>1.0 then Writeln(#7,'Error, sin or cos Out of Range!')
    else
    Case Trigmode of
      0 :  X:=Acos(X);
      1 :  X:=RtoD(Acos(X));
      2 :  X:=RtoG(Acos(X));
     End  { end case }
   End;
  If (Command[I] = 'ASIN') then Begin LstX:=X;
   If Abs(X)>1.0 then Writeln(#7,'Error, sin or cos Out of Range!')
    else
    Case Trigmode of
      0 :  X:=Asin(X);
      1 :  X:=RtoD(Asin(X));
      2 :  X:=RtoG(Asin(X));
     End  { end case }
   End;
  IF (Command[I] = 'FIX') then Begin Comflag:=2;
     Val(Command[I+1],Intval,Error); Fix:=IntVal End;
  If (Command[I] = 'FLOAT') then Fix:=-1;
  If (Command[I] = 'RUP') then Begin
       Temp:=T; Raise_Stack; X:=Temp End;
  If (Command[I] = 'RDOWN') then Begin
       Temp:=X; Lower_Stack; T:=Temp End;
  If (Command[I] = 'CHS') then Begin X:=-X End;
  If (Command[I] = 'STO') then Begin
     ComChar := Command[I+1][1];
     If ComChar[1] in Numerical then Begin
       Val(Command[I+1],Intval,Error); ComFlag:=2 End
      else If ComChar[1] in Op then Begin
        ComFlag:=3; Val(Command[I+2],Intval,Error) End;
     If Intval in [0..Rnum] then
       If ComFlag=2 then R[Intval]:=X else Begin
          If Comchar = '+' then R[Intval]:=R[Intval] + X;
          If ComChar = '-' then R[Intval]:=R[Intval] - X;
          If ComChar = '*' then R[Intval]:=R[Intval]*X;
          If ComChar = '/' then R[Intval]:=R[Intval]/X End
         else Writeln('Error! Only 0 to ',Rnum:0,' memories')
      End;
  If (Command[I] = 'RCL') then Begin
      ComFlag:=2; Val(Command[I+1],Intval,Error);
      If Intval in [0..Rnum] then Begin Raise_Stack; X:=R[Intval] End
       else Writeln('Error! Only 0 to ',Rnum:0,' memories') End;
  If (Command[I] = 'ALOG') then Begin LstX:=X; X:=Pwr(X,10.0) End;
  If (Command[I] = 'PI') then Begin LstX:=X; Raise_Stack; X:=Pi End;
  If (Command[I] = 'X**Y') then Begin Y:=Pwr(Y,X); Lower_Stack End;
  If (Command[I] = 'EX') then Begin Temp:=Y; Y:=X; X:=Temp End;
  If (Command[I] = 'MEM') then Begin
     For II:=Rnum Downto 0 Do Writeln('R[',II:0,']= ',R[II]) End;

   I:=I + Comflag;       { advance along command string proper number }
   Comflag:=1;           { reset to default comflag }
 Until (I= 1 + Comnum);
  Value:=X;
  If Fix >= 0 then Writeln('X: ',X:2:Fix)
         else Writeln('X: ',X);
End;

Begin
 Writeln('Reverse Polish Notation Calculator    Version: ',Version);
 Writeln('Copyright (C) 1987                  C. Scott Blackwell');
 Initialize;
 Repeat
   Write('X:? '); Readln(ComString);
   Parse(ComString,Command,ComNum);
   Execute; X:=Value;
   If Command[Comnum]='DONE' then Done:=True else Done:=False
 Until Done
End.