Developing.ru

Код: Выделить всё

type
  PTree = ^TTree;
  TTRee = record
    val: String;
    Left: PTree;
    Right: PTree;
  end;

function ConvertToRPN(AStr: String): String;
var
  i, k: integer;
  Stack: String;
  StLength: Integer;
  AResult: String;

  function Prior(AOper: String): integer;
  begin
    Prior := -1;
    if AOper='(' then
      Prior := 0
    else if AOper=')' then
      Prior := 1
    else if (AOper='+') or (AOper='-') then
      Prior := 2
    else if (AOper='*') or (AOper='/') then
      Prior := 3
    else if AOper='**' then
      Prior := 4;
  end;

  procedure AddToStack(AOper: Char);
  begin
    inc(StLength);
    Stack := Stack+AOper;
  end;

begin
  AResult := '';
  Stack := '';
  StLength := 0;
  i := 1;
  while i <= Length(AStr) do
  begin
    if Prior(AStr[i]) = -1 then
      AResult := AResult+AStr[i]
    else
    begin
      if High(Stack) = -1 then
        AddToStack(AStr[i])
      else
      begin
        if AStr[i] = '(' then
          AddToStack(AStr[i])
        else
        begin
          if AStr[i] = ')' then
          begin
            k := StLength;
            while (k >= 1) and (Stack[k] <> '(') do
            begin
              AResult := AResult+Stack[k];
              dec(StLength);
              Delete (Stack,Length(Stack),1);
              k := k - 1;
            end;
            dec(StLength);
            Delete (Stack,Length(Stack),1);
          end
          else
          begin
            k := StLength;
            while (k >= 1) and (Prior(Stack[k]) >= Prior(AStr[i])) do {б}
            begin
              AResult := AResult+Stack[k];
              dec(StLength);
              Delete (Stack,Length(Stack),1);
              k := k - 1;
            end;
            AddToStack(AStr[i]);
          end;
        end;
      end;
    end;
    i := i + 1;
  end;
  for i := StLength downto 1 do
  begin
    AResult := AResult+Stack[i];
  end;
  ConvertToRPN := AResult;
end;

function BuildTree (RPN: String): PTree;
var
  VarSt: String;
  TrSt: array [1..50] of PTree;
  TrLength: Integer;

  procedure Add2VarStack (vr: Char);
  begin
    VarSt := VarSt+vr;
  end;

  procedure Add2TrStack (tr: PTree);
  begin
    inc(TrLength);
    TrSt[TrLength] := tr;
  end;

var
  i: Integer;
  tr: PTree;
begin
  TrLength := 0;
  i := 1;
  VarSt := '';
  while i<=Length(RPN) do
    begin
      if (RPN[i]='+') or (RPN[i]='-') or (RPN[i]='*') or (RPN[i]='/')
        or (RPN[i]='**') then
        begin
          New (tr);
          tr^.val := RPN[i];
          if Length(VarSt)>1 then
            begin
              New(tr^.Left);
              tr^.Left^.Left := nil;
              tr^.Left^.Right := nil;
              New(tr^.Right);
              tr^.Right^.Left := nil;
              tr^.Right^.Right := nil;
              tr^.Left^.val := VarSt[Length(VarSt)];
              tr^.Right^.val := VarSt[Length(VarSt)-1];
              Delete (VarSt,Length(VarSt)-1,2);
            end
          else if Length(VarSt)=1 then
            begin
              New(tr^.Left);
              tr^.Left^.Left := nil;
              tr^.Left^.Right := nil;
              tr^.Left^.val := VarSt[Length(VarSt)];
              Delete (VarSt,Length(VarSt),1);
              tr^.Right := TrSt[TrLength];
              dec(TrLength);
            end
          else
            begin
              tr^.Left := TrSt[TrLength];
              tr^.Right := TrSt[TrLength-1];
              dec(TrLength,2)
            end;
          Add2TrStack(tr);
        end
      else
        Add2VarStack(RPN[i]);
      inc(i);
    end;
  BuildTree := TrSt[1];
end;

function GetTree (Str: String): PTree;
begin
  GetTree :=  BuildTree(ConvertToRPN(Str));
end;


procedure PrintTree (Tree: PTree; l: Integer);
begin
  if Tree=nil then
    exit;
  PrintTree (Tree^.Left,l+1);
  WriteLn(Tree^.val:l);
  PrintTree (Tree^.Right,l+1);
end;

var
  tree: PTree;
begin
  tree := nil;
  tree := GetTree('(A+B)*(C+D)-E');
  PrintTree (tree,1);
  WriteLn;
  WriteLn;
  ReadLn;
end.