Преобразование дерева-формулы Опции

[redeezko]

Всем добрый день. Прошу помочь со следующей задачей:

Необходимо описать процедуру, которая преобразует дерево-формулу, заменяя в нем все поддеревья вида ((a*b)+-(c*b)) на ((a+-c)*b). Тип элементов дерева: char, т.е в формуле могут содержаться буквы(переменные)

Например:
дана формула ((5*а)+(3*а)), дерево, ей соответствующее:

--------а
----*
--------3
+
--------а
----*
--------5

На выходе должна получиться формула ((5+3)*а), и дерево:

----а
*
--------3
----+
--------5
Пока что у меня получилось написать только создание и вывод на печать этого дерева:

unit unit_tree;

interface

 type tTree=^Node;
      Node=Record
            Info:Char;
            Left,Right:tTree
           end;

  Procedure print_tree(root:tTree; h:integer);
   {Печать дерева}
  Procedure formula (var root:tTree; s:string);
   {Создание дерева-формулы}
  Procedure copy_tree (var root1:tTree; root:tTree);
//  Procedure proizv(root:tTree; var root1:tTree);

implementation

 const
  Operations=['-','+','*'];

 procedure print_tree;
  var
   i:integer;
  begin
   if root<>nil then
     begin
      print_tree (root^.Right,h+1);
      for i:=1 to h do write('    ');
      writeln(root^.Info);
      print_tree(root^.Left,h+1)
     end
  end;

 procedure copy_tree;
  begin
   if root<>nil then
     begin
      new (root1);
      root1^.info:=root^.info;
      copy_tree(root1^.Left,root^.Left);
      copy_tree(root1^.Right,root^.Right)
     end
    else root1:=nil
  end;

 function prior (a:char):byte;
  {Приоритет арифметической операции}
  begin
   case a of
    '+','-': prior:=1;
    '*':     prior:=2
   end
  end;

 procedure Delete_Brackets (var s:string);
  {Удаление крайних скобок }
  var
   i,n:integer;
  begin
    if s[1]='(' then
     begin
      n:=0;
      i:=2;
      while (n>=0) and (i<length(s)) do
       begin
        if s[i]='(' then inc(n)
         else if s[i]=')' then dec(n);
        inc(i)
       end;
      if n=0 then
       begin
        delete(s,1,1);
        delete(s,length(s),1)
       end
     end
  end;

 function Find_Root (var s:string):integer;
  {Поиск позиции "корня" для каждого поддерева}
  var
   pr,i,n:integer;
  begin
   Delete_Brackets(s);
   pr:=3;
   Find_Root:=0;
   i:=length(s);
   while (i>1) and (pr>1) do
    if s[i]=')' then
      begin
       n:=1;
       while n<>0 do
        begin
         dec(i);
         if s[i]=')' then inc(n)
          else if s[i]='(' then dec(n)
        end;
       dec(i)
      end
    else
     if (s[i] in Operations) and (prior(s[i])<pr) then
      begin
       Find_Root:=i;
       pr:=prior(s[i]);
       dec(i)
      end
      else dec(i)
  end;

 procedure formula;
  var
   n_pos:integer;
  begin
   n_pos:=Find_Root(s);
   if n_pos<>0 then
     begin
      new(root);
      root^.info:=s[n_pos];
      formula(root^.Left,copy(s,1,n_pos-1));
      formula(root^.Right,copy(s,n_pos+1,length(s)-n_pos))
     end
    else
     begin
      new(root);
      root^.info:=s[1];
      root^.Left:=nil;
      root^.Right:=nil
     end
  end;

А как найти необходимое для замены поддерево, а затем его заменить, я и не знаю..

Сообщение отредактировано: redeezko - 6.12.2010 13:18

[TarasBer]

> delete(root^.Left);
delete(root^.right);

Я же сказал, их надо удалить, как узлы, а не как деревья. После такого удаления a, b, c тоже удаляются.
Замени на Dispose.

> Var a,b,c:char;

Запомни не инфо, а указатели на эти деревья.

var a: TTree;
...
a:=root^.right^.left;

И добавь удаление root^.right^.right (как дерева).

Добавлено через 1 мин.
Кстати, твоя процедура Delete виснет. Потому что у любой рекурсии должно быть условие выхода. В начало процедуры Delete допиши if root = nil then Exit;
а в конец допиши root := nil;