old/PAS/!SPbSTU/Boris/9.PAS

{
 Доступные операции:
  +-*/ - стандартно
  ^    - возведение в степень
}

const
 deyst  = ['+','-','*','/','^',')','('];

type
  pTree = ^tTree;
  tTree = record
   operand   : real;
   operation : char;
   left  : pTree;
   right : pTree;
  end;

 stack = ^tstack;
 tstack = record
  t : pTree;
  n : stack;
 end;
{------------------------------}
Procedure CreateBranch(var aStack : stack;aCurOper : char);
var
 aN : pTree;
 aL : stack;
begin
 if (aStack = nil) or (aStack^.n = nil) then
  begin
   WriteLn('Error in operators');
   Halt(255);
  end;
 New(aN);
 with aN^ do
  begin
   operation := aCurOper;
   Right:=aStack^.t;
   aL := aStack;
   aStack := aStack^.n;
   Dispose(aL);
   Left :=aStack^.t;
   aL:=aStack;
   aStack := aStack^.n;
   Dispose(aL);
   aL:=aStack;
  end;
 New(aStack);
 aStack^.n := aL;
 aStack^.t := aN;
end;
{------------------------------}
function GetPrior(a:char):integer;
begin
  case a of 
   '(':GetPrior:=5;
   ')':GetPrior:=5;
   '+':GetPrior:=10;
   '-':GetPrior:=10;
   '*':GetPrior:=20;
   '/':GetPrior:=20;
   '^':GetPrior:=30;
   else begin
         WriteLN('Sorry, undefined operation, ''',a,'''');
        end;
  end;
end;
{------------------------------}
function GetToken(var aStr:string;var aPos:byte):string;
var
 ret:string;                   
begin
 ret:='';
 while (aStr[aPos] = ' ') and (aPos <= ord(aStr[0])) do inc(aPos);
 if aStr[aPos] in Deyst then
 begin
  ret := aStr[aPos];
  inc(aPos)
 end
 else
  while (aStr[aPos] in ['0'..'9','.']) and (aPos <= ord(aStr[0])) do
  begin
   ret:=ret + aStr[aPos];
   inc(aPos);
  end;
 while (aStr[aPos] = ' ') and (aPos <= ord(aStr[0])) do inc(aPos);
 GetToken:=ret;
end;
{------------------------------}
Function CreateTree(aInp:string):pTree;
var

 operations : string;
 token      : string;
 opPos,sPos : byte;
 LastOprtn  : Boolean;
 retcode    : integer;
 TreeStack  : stack;
 NewEl      : stack;
begin
 sPos:=1;
 operations[0] := #255;
 LastOprtn := true;
 TreeStack := nil;
 opPos := 0;
 while sPos <= ord(aInp[0]) do
 begin
  Token := GetToken(aInp,sPos);
  if Token[1] in Deyst then
  begin
   if Token[1] <> '(' then
    if LastOprtn then
     begin
      WriteLn('Error in input: ',aInp);
      WriteLn('Expected operation at position near ''',Copy(aInp,sPos-Length(Token),5),'''');
      Halt(236);
     end
    else
     while (opPos > 0) and (GetPrior(Token[1]) < GetPrior(operations[opPos])) do
      begin
       CreateBranch(TreeStack,operations[opPos]);
       dec(opPos);
      end;
   if Token[1] <> ')' then 
    begin
     inc(opPos);
     operations[opPos] := Token[1];
     LastOprtn := true;
    end
   else
    Dec(opPos);
  end
  else
   begin
    if not LastOprtn then
     begin
      WriteLn('Error in input: ',aInp);
      WriteLn('Expected operand at position near ''',Copy(aInp,sPos-Length(Token),5),'''');
      Halt(236);
     end;
    New(NewEl);
    NewEl^.n := TreeStack;
    new(NewEl^.t);
    with NewEl^.t^ do
    begin
     left:=nil;
     right:=nil;
     Val(Token,operand,retcode);
     operation := ' ';
     if retcode <> 0 then
      begin
       WriteLn('Error in input: ',aInp);
       WriteLn('in position ',sPos-Length(Token));
       Halt(255);
      end;
    end;
    TreeStack := NewEl;
    LastOprtn := False;
   end;
  end;
  while opPos > 0 do
   begin
    CreateBranch(TreeStack,operations[opPos]);
    dec(opPos);
   end;
 CreateTree := TreeStack^.t;
 Dispose(TreeStack);   
end;
{------=-=-=-=--==-=-=-=--=--==--=}
Procedure ToPostfix(aT:pTree;var aOut:string);
var
 aStr : string[13];
begin
 if aT = nil then exit;
 ToPostfix(aT^.Left,aOut);
 ToPostfix(aT^.Right,aOut);
 if aT^.Operation = ' ' then
  begin
   Str(aT^.operand:0:0,aStr);
   aOut:=aOut+aStr+' ';
  end
 else
   aOut:=aOut+aT^.Operation+' ';  
end;
{-----------------------}
Function aInb(a,b:real):real;
begin
 if a > 0 then
  aInb:=Exp(b*Ln(a))
 else
  aInb:=0;
end;
{-----------------------}
Function CalculateTree(aT: pTree):real;
begin
 if aT=nil then exit;
 Case aT^.Operation of
   ' ': CalculateTree:=aT^.Operand;
   '+': CalculateTree:=CalculateTree(aT^.Left) + CalculateTree(aT^.Right);
   '-': CalculateTree:=CalculateTree(aT^.Left) - CalculateTree(aT^.Right);
   '*': CalculateTree:=CalculateTree(aT^.Left) * CalculateTree(aT^.Right);
   '/': CalculateTree:=CalculateTree(aT^.Left) / CalculateTree(aT^.Right);
   '^': CalculateTree:=aInb(CalculateTree(aT^.Left),CalculateTree(aT^.Right));
 end;
end;
{-----------------------}
Procedure DisposeTree(aT : pTree);
begin
  if aT <> nil then 
  Begin
   DisposeTree(aT^.Left);
   DisposeTree(aT^.Right);
   Dispose(aT);
  end;
end;
{-------}
var
 aIn : string;
 aOut : string;
 Tree :pTree;
begin
 Assign(input,'9.txt');
 {$I-}
  Reset(input);
  if IOResult <> 0 then
   begin
    WriteLn('File 9.txt not found!');
    halt(255);
   end;
 {$I+}
 Readln(aIn);
 Close(input);
 aOut :='';
 Tree := CreateTree(aIn);
 ToPostfix(Tree,aOut);
 Assign(OutPut,'9.out');
 Rewrite(OutPut);
 WriteLn('Выражение в постфикс. форме: ',aOut);
 WriteLn('Результат: ',CalculateTree(Tree):0:3);
 Close(output);
 DisposeTree(Tree);
end.