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

[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]

Ну тупо перебором.
Сначала напиши функцию, проверяющую деревья на равенство (рекурсия).
Потом просто тупо пишешь "если в вершине плюс, в потомках умножение и правые потомки потомков совпадают или левые потомки потомков совпадают, то делаем упрощение".

[redeezko]

C проверкой дерева вроде бы справился, а вот преобразование и вывод на печать не получается.

[TarasBer]

Ну для преобразования дерева +(*ab)(*cb) надо одно из b удалить (как дерево, то есть с детьми), a, b, c запомнить, уничтожить узлы с умножением (как узлы, детей не трогать), в главной вершине заменить + на *, правого потомка сослать на b, левого потомка создать с символом +, задать ему потомков a и c.
Короче, тупая ручная работа.
Когда заставят производные автоматом считать, будет ещё круче.

[redeezko]

Дописал процедуру удаления дерева, и процедуру преобразования

Procedure Delete(root:tTree);
 Begin
  Delete(root^.Right);
  Delete(root^.Left);
  Dispose(root)
End;

   Procedure Transformation;
    Var a,b,c:char;
    Begin
      a:=root^.right^.left^.Info;
      b:=root^.right^.right^.info;
      c:=root^.left^.left^.info;
      delete(root^.Left);
      delete(root^.right);
      root^.Info:='*';
      root^.Right^.Info:=b;
      root^.Left^.info:='+';
      root^.left^.Right^.info:=a;
      root^.Left^.left^.Info:=c
   end;

Только преобразованное дерево не выводится на печать.

[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;

[redeezko]

Переделал:

Procedure Delete(root:tTree);
 Begin
  if root=nil then exit;
  Delete(root^.Right);
  Delete(root^.Left);
  Dispose(root)
End;

   Procedure Transformation;
    Var a,b,c:tTree;
    Begin
      a:=root^.right^.left;
      b:=root^.right^.right;
      c:=root^.left^.left;
      dispose(root^.Left);
      dispose(root^.right);
      delete(root^.Right^.right);
      root^.Info:='*';
      root^.Right:=b;
      root^.Left^.Info:='+';
      root^.left^.Right:=a;
      root^.Left^.left:=c
   end;

Но результат тот же самый. Делал трассировку. оказывается что то неверно с процедурой Delete. Программа доходит до строки Delete(root^.Right); и прерывается. Остальное все верно, так как если эту процедуру не выполнять в Transformation, то всё печатается правильно.

Добавлено через 3 мин.
дописал:

Procedure Delete(root:tTree);
 Begin
  if root=nil then exit;
  Delete(root^.Right);
  Delete(root^.Left);
  Dispose(root);
  root:=nil;
End;

ничего не изменилось

[TarasBer]

> Программа доходит до строки Delete(root^.Right); и прерывается.

Значит, у тебя ошибка при создании дерева - неиспользуемый потомок не инициализируется nilом.
А где именно - найти что-то не могу пока.

> Остальное все верно, так как если эту процедуру не выполнять в Transformation, то всё печатается правильно.

...и добрый дядя ГЦ всё подотрёт...
Ты уж доведи Delete до ума.

[offtop]
алгоритм разбора строки ужасен, но я с такого же начинал в своё время
можно вообще делать в 1 проход, на самом деле
http://algolist.manual.ru/syntax/
[/offtop]

[redeezko]

Ну получается до ума надо доводить не процедуру удаления, а процедуру создания дерева.. Буду пытаться это сделать.

Добавлено через 4 мин.
И спасибо за ссылку, разберусь на досуге. Но сейчас главное сделать эту задачу

Добавлено через 3 мин.
Исправил процедуру formula, дописав две строки:

p
   if n_pos<>0 then
     begin
      new(root);
      root^.info:=s[n_pos];
      root^.Left:=nil;               {эта}
      root^.Right:=nil;             {и эта}  
      formula(root^.Left,copy(s,1,n_pos-1));
      formula(root^.Right,copy(s,n_pos+1,length(s)-n_pos))
     end

Но результата опять нет.. Хотя вроде бы теперь неипользуемые потомки должны быть Nil.

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

[TarasBer]

Может дело тут?

Procedure Delete(var root:tTree);

[redeezko]

Нет, не помогло.

Добавлено через 7 мин.
Сделал. Проблема оказалась совсем в другом

      dispose(root^.Left);
      dispose(root^.right);
      delete(root^.Right^.right);

При удалении узла, мы уже не можем перейти к потомкам, так как связь нарушена.

      delete(root^.Right^.right);
      dispose(root^.Left);
      dispose(root^.right);

А вот так всё работает! Благодарю за помощь!