old/PAS/!SPbSTU/EQuations.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) AND NOT (aCurOper IN ['~','c','s','l','t','o'])) 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);
   if not (aCurOper in ['~','c','s','l','t','o']) then
    begin
     Left :=aStack^.t;
     aL:=aStack;
     aStack := aStack^.n;
     Dispose(aL);
    end
   else Left:=nil;
   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:=100;
   '+':GetPrior:=10;
   '-':GetPrior:=12;
   '*':GetPrior:=20;
   '/':GetPrior:=22;
   '^':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
 if aStr[aPos] in ['0'..'9','.'] then
  while (aStr[aPos] in ['0'..'9','.']) and (aPos <= ord(aStr[0])) do
  begin
   ret:=ret + aStr[aPos];
   inc(aPos);
  end
 else
 begin
  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
   begin
    if (sPos=2) OR (aInp[sPos-2] = '(') then
     begin
      inc(opPos);
      operations[opPos] := '~';
      LastOprtn := true;
     end;
   end
   else
    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
  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;
     if Token[1] IN ['0'..'9','.'] then
     begin
      Val(Token,operand,retcode);
      operation := ' ';
     end
     else
      operation := 'x';

     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:1,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; aX:real):real;
begin
 if aT=nil then exit;
 Case aT^.Operation of
   ' ': CalculateTree:=aT^.Operand;
   'x': CalculateTree:=aX;
   '~': CalculateTree:=-CalculateTree(aT^.Right,aX);
   '+': CalculateTree:=CalculateTree(aT^.Left,aX) + CalculateTree(aT^.Right,aX);
   '-': CalculateTree:=CalculateTree(aT^.Left,aX) - CalculateTree(aT^.Right,aX);
   '*': CalculateTree:=CalculateTree(aT^.Left,aX) * CalculateTree(aT^.Right,aX);
   '/': CalculateTree:=CalculateTree(aT^.Left,aX) / CalculateTree(aT^.Right,aX);
   '^': CalculateTree:=aInb(CalculateTree(aT^.Left,aX),CalculateTree(aT^.Right,aX));
 end;
end;
{-----------------------}
Procedure DisposeTree(aT : pTree);
begin
  if aT <> nil then
  Begin
   DisposeTree(aT^.Left);
   if aT^.Right <> nil then DisposeTree(aT^.Right);
   Dispose(aT);
  end;
end;
{-------}
var
 aIn : string;
 aOut : string;
 Tree :pTree;
begin
 aIn := '-3*(-x)';
 aOut :='';
 Tree := CreateTree(aIn);
 ToPostfix(Tree,aOut);
{ Assign(OutPut,'9.out');
 Rewrite(OutPut);}
 WriteLn('‚ëà ¦¥­¨¥: ',aIn);
 WriteLn('‚ëà ¦¥­¨¥ ¢ ¯®áâ䨪á. ä®à¬¥: ',aOut);
 WriteLn('�¥§ã«ìâ â: ',CalculateTree(Tree, 1):0:3 );
 Close(output);
 DisposeTree(Tree);
end.