Program RPN; { a HP-style reverse Polish notation calculator }
{ Copyright (C) 1987         C. Scott Blackwell }
{ program has no screen-oriented control so should work with virtually
  an plain CP/M or Pascal system with little or no alteration.
  String functions are used and they are not standard Pascal! }

Type
 String80 = String[80];

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

Var
  X,Y,Z,T,Value,Comnum: Real; { the HP stack }
  LstX: Real;      { last x }
  R: Array [0..Rnum] of Real;  { ten storage locations }
  Done,Degree,Opcom: Boolean;
  IntVal,Opt,Fix,Trigmode: Integer;
 { Trigmode = 0 radians, 1 degrees, 2 grads }
  Command: 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        C. Scott Blackwell'); Writeln;
  Writeln('Works like a RPN calculator;  Functions supported are :');
  Writeln('HELP or ?  -> This screen.  '); Writeln;
  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('ROUND, 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 function on the number and replace X with the result.');
  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; Opt:=-1; 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 Command:String80; Var Value:Real; Var Opt, IntVal:Integer);

Var
 Numstring,Comstring: String80;
 Sep,Lcom,I: Integer;
 Done: Boolean;
 Error:Integer;

Begin
 Sep:=Pos(Sp,Command);
 Lcom:=Length(Command); Opt:=0;
 If Lcom=0 then Begin Command:='ENTER'; Value:=X End;
 If Sep>0 then Begin
    If Command[1] in Alpha then Begin
       Numstring:=Copy(Command,Sep+1,Lcom-Sep);
       If Numstring[1] in Op then Opcom:=True else Opcom:=False;
       If Opcom then
        Begin
          Comchar:=NumString[1]; Delete(Numstring,1,1)
        End;
       Val(Numstring,IntVal,Error);
       ComString:=Copy(Command,1,Sep-1); Command:=Comstring
       End
    End;
 If Not((Command[1] in Sign) and (Lcom=1)) then
  If (Command[1] in Numerical)  then Begin
   If Sep=0 then Begin NumString:=Command; Command:='ENTER' End
     else
      Begin
        NumString:=Copy(Command,1,Sep-1);
        Command:=Copy(Command,Sep+1,Lcom-Sep);
        Opt:=1
      End;
    Val(Numstring,Value,Error)
  End
  Else Value:=X;
  { if no # at start Command is the whole string - no parsing! }
  For I:=1 to Length(Command) Do Command[I]:=UpCase(Command[I])
End;

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

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

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

Procedure Execute(Command: String80;  Value:Real; Var Opt,IntVal:Integer);

Var
  Temp: Real;
  I: Integer;

Begin
  If (Opt=1) then Begin Raise_Stack; X:=Value End;
  If (Command = 'HELP') or (Command = '?') then Help_Menu;
  If (Command = 'ENTER') then
     Begin
       Raise_Stack; X:=Value;
     End;
  If (Command = '*') then Begin
              LstX:=X; Y:=X*Y;  Lower_Stack End;
  If (Command = '/') then Begin
              LstX:=X; Y:=Y/X;  Lower_Stack End;
  If (Command = '+') then Begin
              LstX:=X; Y:=Y+X; Lower_Stack End;
  If (Command = '-') then Begin
              LstX:=X; Y:=Y-X; Lower_Stack End;
  If (Command = 'SQR') then Begin LstX:=X; X:=X*X End;
  If (Command = 'SQRT') then Begin LstX:=X; X:=Sqrt(X) End;
  If (Command = 'STK') then WriteStack;
  If (Command = 'LSTX') then Begin Raise_Stack; X:=LstX End;
  If (Command = 'EXP') then Begin LstX:=X; X:=Exp(X) End;
  If (Command = 'LN') then Begin LstX:=X; X:=Ln(X) End;
  If (Command = 'LOG') then Begin LstX:=X; X:=Log(X) End;
  If (Command = 'R') then Begin LstX:=X; X:=1/X End;
  If (Command = 'INT') then Begin LstX:=X; X:=Trunc(X) End;
  If (Command = 'FRAC') then Begin LstX:=X; X:= X-Trunc(X) End;
  If (Command = 'RAD') then  Trigmode:=0;
  If (Command = 'DEG') then  Trigmode:=1;
  If (Command = 'GRAD') then Trigmode:=2;
  If (Command = 'SIN') then
    Begin LstX:=X; TrigCycle(X); X:=Sin(X) End;
  If (Command = 'COS') then
    Begin LstX:=X; TrigCycle(X); X:=Cos(X) End;
  If (Command = '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 = '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 = 'ACOS') then Begin LstX:=X;
   If Abs(X)>1.0 then Writeln(Chr(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 = 'ASIN') then Begin LstX:=X;
   If Abs(X)>1.0 then Writeln(Chr(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 = 'FIX') then Fix:=IntVal;
  If (Command = 'FLOAT') then Fix:=-1;
  If (Command = 'RUP') then Begin
     Temp:=T; Raise_Stack; X:=Temp End;
  If (Command = 'RDOWN') then Begin
     Temp:=X; Lower_Stack; T:=Temp End;
  If (Command = 'ROUND') then Begin LstX:=X;
    If Fix>0 then
      Begin
       Temp:= X; For I:=1 to Fix Do Temp:=Temp*10.0;
       X:= Round(Temp); For I:=1 to Fix Do X:=X/10.0
      End
    else If Fix = 0 then X:=Round(X)
  End;
  If (Command = 'CHS') then X:=-X;
  If (Command = 'STO') then Begin
     If Intval in [0..Rnum] then
       If not(Opcom) 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(Chr(7),'Error! Only 0 to ',Rnum:0,' memories')
      End;
  If (Command = 'RCL') then
      If Intval in [0..Rnum] then X:=R[Intval]  else
          Writeln(Chr(7),'Error! Only 0 to ',Rnum:0,' memories');
  If (Command = 'ALOG') then Begin LstX:=X; X:=Pwr(X,10.0) End;
  If (Command = 'PI') then Begin LstX:=X; Raise_Stack; X:=Pi End;
  If (Command = 'X**Y') then Begin LstX:=X; Y:=Pwr(Y,X); Lower_Stack End;
  If (Command = 'EX') then Begin Temp:=Y; Y:=X; X:=Temp End;
  If (Command = 'MEM') then For I:=Rnum Downto 0 Do
      Writeln('R[',I:0,']= ',R[I]);
  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(Command);
   Parse(Command,Value,Opt,IntVal);
   Execute(Command,Value,Opt,IntVal);
   Value:=X;
   If (Command='DONE') or (Command = 'QUIT') then
       Done:=True else Done:=False
 Until Done
End.