{
From: WARREN PORTER
Subj: eval
Program to evaluate expressions using a stack. }

const
  Maxstack = 100;

type

  stack = record
        top : 0..Maxstack;
        Item : array[1..Maxstack] of char
        end;

  RealStack = record
        top: 0..Maxstack;
        Item : array[1..Maxstack] of real
        end;

  xptype = record
        oper : char;
        opnd : real
        end;

Function Empty(var A:stack):boolean;

Begin
  Empty:= A.top = 0;
End;

Function Pop(var A:stack):char;

Begin
  if A.Top < 1 then
    begin
      writeln('Attempt to pop an empty stack');
      halt(1)
    end;
  Pop:= A.item[A.top];
  A.top:= A.top - 1
End;

Procedure Push(var A:stack; Nchar:char);

Begin
  if A.Top = Maxstack then
    begin
      writeln('Stack already full');
      halt(1)
    end;
  A.top:= A.top + 1;
  A.item[A.top]:=Nchar
End;

     {The following functions are for the real stack only.}

Function REmpty(var D:RealStack):boolean;

Begin
  REmpty:= D.top = 0;
End;

Function RPop(var D:RealStack):real;

Begin
  if D.Top < 1 then
    begin
      writeln('Attempt to pop an empty RealStack');
      halt(1)
    end;
  RPop:= D.item[D.top];
  D.top:= D.top - 1
End;

Procedure RPush(var D:RealStack; Nreal:real);

Begin
  if D.Top = MaxStack then
    begin
      writeln('Stack already full');
      halt(1)
    end;
  D.top:= D.top + 1;
  D.item[D.top]:=Nreal
End;

Function pri(op1, op2:char):boolean;

var
  tpri: boolean;
Begin
  if op2 = ')' then
    tpri:= true                            else
  if (op1 = '$') and (op2 <> '$') and (op2 <> '(')  then
    tpri:= true                            else
  if (op1 in ['*','/']) and (op2 in ['+','-']) then
    tpri:= true
  else
    tpri:= false;
  pri:= tpri{;
  write('Eval op 1= ',op1, ' op2 = ',op2);
  if tpri= false then
     writeln(' false')
  else
     writeln(' true')}
End;

Function ConvReal(a:real;NumDec:integer):real;

var
   i, tenpower: integer;

Begin
   tenpower:= 1;
   for i:= 1 to NumDec do
      tenpower:= tenpower * 10;
   ConvReal:= a / tenpower
End;

Function ROper(opnd1, opnd2: real; oper: char):real;
Var temp: real;

Begin
   Case oper of
      '+': temp:= opnd1 + opnd2;
      '-': temp:= opnd1 - opnd2;
      '*': temp:= opnd1 * opnd2;
      '/': temp:= opnd1 / opnd2;
      '$': temp:= exp(ln(opnd1) * opnd2)
   End {Case}     ;
   {Writeln(opnd1:6:3,' ',oper,' ',opnd2:6:3 ,' = ',temp:6:3);}
   ROper := temp
End; {R oper}

{Main procedure starts here}

var
  A: stack;
  Inbuff:string[Maxstack];
  len, i, j, NumDecPnt, lenexp: integer;
  temp, opnd1, opnd2, result : real;
  valid, expdigit, expdec, isneg, openok: boolean;
  operators, digits : set of char;
  HoldTop : char;
  B: array[1..Maxstack] of xptype;
  C: array[1..Maxstack] of xptype;
  D: RealStack;

Begin
  digits:= ['0'..'9'];
  operators:= ['$','*','/','+','-','(',')'];
  Writeln('Enter expression to evaluate or RETURN to stop');
  Writeln('A space should follow a minus sign unless it is used to');
  Writeln('negate the following number.  Real numbers with multi-');
  Writeln('digits and decimal point (if needed) may be entered.');
  Writeln;
  Readln(Inbuff);
  len:=length(Inbuff);

  repeat
    i:= 1;
    A.top:= 0;
    valid:= true;
    repeat
      if Inbuff[i] in ['(','[','{'] then
        push(A,Inbuff[i])
      else
        if Inbuff[i] in [')',']','}'] then
          if empty(A) then
            valid:= false
          else
            if (ord(Inbuff[i]) - ord(Pop(A))) > 2 then
              valid:= false;
      i:= i + 1
    until (i > len) or (not valid);
    if not empty(A) then
      valid:= false;
    if not valid then
      Writeln('The expression is invalid')
    else
      Begin
         {Change all groupings to parenthesis}
         for i:= 1 to len do Begin
           if Inbuff[i] in ['[','{'] then
              Inbuff[i]:= '('  else
           if Inbuff[i] in [']','}'] then
              Inbuff[i]:= ')';
           B[i].oper:= ' ';
           B[i].opnd:= 0;
           C[i].oper:= ' ';
           C[i].opnd:= 0    End;

         { The B array will be the reformatted input string.
           The C array will be the postfix expression. }

         i:= 1; j:= 1; expdigit:= false; expdec:= false; isneg:= false;
         while i <= len do
            Begin
               if (Inbuff[i] = '-') and (Inbuff[i + 1] in digits) then
                  Begin
                     isneg:= true;
                     i:= i + 1
                  End;
               if (Inbuff[i] = '.' ) then  Begin
                  i:= i + 1;
                  expdec:= true            End;
               if Inbuff[i] in digits then
                  Begin
                     if expdec then
                        NumDecPnt:= NumDecPnt + 1;
                     if expdigit then
                        temp:= temp * 10 + ord(inbuff[i]) - ord('0')
                     else                  Begin
                        temp:= ord(inbuff[i]) - ord('0');
                        expdigit:= true    End
                  End
               else
                  if expdigit = true then    Begin
                     if isneg then
                        temp:= temp * -1;
                     B[j].opnd:= ConvReal(temp,NumDecPnt);
                     j:= j + 1;
                     expdigit := false;
                     expdec   := false;
                     NumDecPnt:= 0;
                     isneg:= false           End;

               If Inbuff[i] in operators     then Begin
                  B[j].oper:= Inbuff[i];
                  j:= j + 1                       End;

               if not (Inbuff[i] in digits)    and
                  not (Inbuff[i] in operators) and
                  not (Inbuff[i] = ' ') then                Begin
                  Writeln('Found invalid operator: ',Inbuff[i]);
                  valid:= false                             End;

               i:= i + 1;

            End;  {While loop to parse string.}

            if expdigit = true then    Begin
               if isneg then
                  temp:= temp * -1;
               B[j].opnd:= ConvReal(temp,NumDecPnt);
               j:= j + 1;
               expdigit := false;
               expdec   := false;
               NumDecPnt:= 0;
               isneg:= false           End;

      End; {First if valid loop.  Next one won't run if invalid operator}

    if valid then
      Begin
         lenexp:= j - 1;    {Length of converted expression}
         writeln;
         for i:= 1 to lenexp do
            Begin
               if B[i].oper = ' ' then
                  write(B[i].opnd:2:3)
               else
                  write(B[i].oper);
               write(' ')
            End;

         {Ready to create postfix expression in array C }

         A.top:= 0;
         j:= 0;

         for i:= 1 to lenexp do
            Begin
               {writeln('i = ',i);}
               if B[i].oper = ' ' then       Begin
                  j:= j + 1;
                  C[j].opnd:= B[i].opnd      End
               else
                  Begin
                  openok := true;
                     while (not empty(A) and openok and
                           pri(A.item[A.top],B[i].oper)) do
                        Begin
                           HoldTop:= pop(A);
                           if HoldTop = '(' then
                              openok:= false
                           else
                              Begin
                                 j:= j + 1;
                                 C[j].oper:=HoldTop
                              End
                        End;
                     if B[i].oper <> ')' then
                        push(A,B[i].oper);
                  End; {Else}
            End; {For loop}

            while not empty(A) do
               Begin
                  HoldTop:= pop(A);
                  if HoldTop <> '(' then
                     Begin
                        j:= j + 1;
                        C[j].oper:=HoldTop
                     End
               End;

         lenexp:= j;  {Since parenthesis are not included in postfix.}

         for i:= 1 to lenexp do
            Begin
               if C[i].oper = ' ' then
                  write(C[i].opnd:2:3)
               else
                  write(C[i].oper);
               write(' ')
            End;

         {The following evaluates the expression in the real stack}

         D.top:=0;
         for i:= 1 to lenexp do
            Begin
               if C[i].oper = ' ' then
                  Rpush(D,C[i].opnd)
               else
                  Begin
                     opnd2:= Rpop(D);
                     opnd1:= Rpop(D);
                     result:= ROper(opnd1,opnd2,C[i].oper);
                     Rpush(D,result)
                  End {else}
            End; {for loop}
         result:= Rpop(D);
         if Rempty(D) then
            writeln('    = ',result:2:3)
         else
            writeln('    Could not evaluate',chr(7))
      End;

    Readln(Inbuff);
    len:= length(Inbuff)
  until len = 0
End.