Левопрошитое дерево, проблемы Опции

[Jill]

Основной принцип: левый - потомок, правый - брат.
Описание дерева:

 type
    PTree=^TTree;
    TTree=record
      LL:PTree;    {левый указатель - на потомка если True, на предка если False}
      RL:PTree;    {правый указатель - на братьев}
      Key:string;  {ключ}
      Sign:boolean; {признак существования потомков}
    end; 

Если вершины нет, то создаем ее:

 if root=NIL then begin
    new(root);
    root^.LL:=root;   {сам на себя - предков нет}
    root^.RL:=NIL;    {нет братьев}
    root^.Key:='root';
    root^.Sign:=false; {нет потомков}

Добавление... Вроде существует два варианта - либо это первый потомок, либо нет. Не выходит реализовать это условие

 procedure AddElem(chto:string; kuda:PTree);
begin
    new(node);
    if kuda^.Sign=false then begin
      kuda^.LL:=node;    {на сына }
      kuda^.Sign:=true;  {у kuda появился потомок}
      node^.RL:=NIL;     {у node нет братьев}
      node^.LL:=kuda;    {на отца}
      node^.Key:=chto;
      node^.Sign:=false;  {у node нет потомков}
      end
    else begin  
      node:=kuda^.LL;    {находим первого сына}
      while node^.RL<>NIL do
        begin node:=node^.RL; end;  {продвигаемся по правой ветви}
        node^.RL:=NIL;
        node^.LL:=kuda;
        node^.Key:=chto;
        node^.Sign:=false;  
      end;
end;

.
Подскажите, плз, как с этим разобраться...

Сообщение отредактировано: volvo - 3.11.2006 19:49

[volvo]

Смотри, как я попробовал бы сделать:

type
  PTree=^TTree;
  TTree=record
    LL: PTree;
    RL: PTree;
    Key:string;
    Sign:boolean;
  end;

procedure Create(var root: PTree);
begin
  if root = nil then begin
    new(root);
    with root^ do begin
      LL := nil;     { <-- нет родителя - зачем присваивать себя? Работай с Nil }
      RL := nil;
      Key := 'root';
      Sign := false; { <-- нет потомков }
    end;
  end;
end;

{ Здесь: kuda описывается, как Var параметр, т.к. внутри процедуры он изменяется }
procedure AddElem(chto: string; var kuda: PTree);
var p, node: PTree;
begin
  new(node); { <-- Забрали память под новый элемент }
  if kuda^.Sign = false then begin
    { Если у элемента, к которому надо добавить новый, нет потомков }

    node^.RL := NIL; { у только что созданного элемента в любом случае нет братьев }
    node^.LL := kuda; { заполняем поле предка }
    node^.Key:=chto;
    node^.Sign:=false; { потомков у нового элемента тоже нет }

    kuda^.LL := node; { а вот у kuda появился потомок: здесь запоминаем его адрес }
    kuda^.Sign:=true; { и устанавливаем признак существования потомка }
  end
  else begin
    {
      В этом случае - у элемента, которому надо добавить новый
      уже есть потомки, так что добавляемых элемент будет братом
      последнего из них
    }

    { ищем этого брата, для чего используем новую переменную P }
    p := kuda^.LL; { это первый, "старший" из братьев }
    while p^.RL <> nil do
      p := p^.RL;
    { теперь в P хранится адрес "младшего" брата, к нему добавим еще одного }

    node^.RL:=NIL; { "младших братьев" пока нет }
    node^.LL:=kuda; { устанавливаем предка }
    node^.Key:=chto; 
    node^.Sign:=false; { потомков, естественно, тоже пока нет }

    p^.RL := node; { а вот теперь изменяем RL у БЫВШЕГО "младшего" брата }
  end;
end;

[Jill]

Еще раз спасибо за подробные комменты

Дописала пару процедур обработки - поиска и изменения элемента. Вроде работает, но затыкается при попытке пройтись "в глубину". Не могу понять, в чем дело...

function FindNode(T:PTree;ToFind:string):PTree;
begin
    If T=NIL Then Exit;
    if T^.Key=ToFind then begin FindNode:=T; exit end
      else FindNode:=NIL;
    if T^.Sign then FindNode(T^.LL,ToFind);
    if T^.RL<>NIL then FindNode(T^.RL,ToFind);
end;

procedure ChangeNode(p:PTree;ToChange:string);
var pp: PTree;
  begin
    if FindNode(p,ToChange)<>NIL then begin
    pp:=FindNode(p,ToChange);
    pp^.Key:='node7'; end
end;

Процедура вывода вроде без ошибок:

Procedure PrintDown(T:PTree;st:string);
begin
   If T = nil Then Exit;
   writeln(st+T^.key);
   if T^.Sign then PrintDown(T^.LL,St+st);
   if T^.RL<>NIL then PrintDown(T^.RL,St);
end;

Сообщение отредактировано: volvo - 3.11.2006 19:49

[volvo]

Jill, ты программку-то свою приведи, как именно ты пытаешься работать с этими процедурами/функциями?

(сразу, не проверяя, могу сказать, что функция FindNode не очень мне нравится, т.к. не в каждой точке выхода она возвращает значение, а это плохо)

[Jill]

Дело в том, что мне необходимо оформить работу в делфях. Как работают процедуры в паскальных набросках примитивны - просто вызов и что из этого получится. Функция FindNode необходима для поиска элемента, который надо изменить (ChangeNode) или для поиска элемента, подлежащего удалению.
Код вот (повторюсь, главная программа - примитивна - мне нужно понять):

" (Показать/Скрыть)

 type
    PTree=^TTree;
    TTree=record
      LL:PTree;
      RL:PTree;
      Key:string;
      Sign:boolean;
    end;

var
  root,node,curr:PTree;
  s:string;

procedure CreateTree(var root:PTree);
begin
  if root=NIL then begin
    new(root);
    root^.LL:=NIL;
    root^.RL:=NIL;
    root^.Key:='root';
    root^.Sign:=false;
  end;
end;

procedure AddNode(chto:string; var father:PTree);
begin
  new(node);
  if father^.Sign=false then begin
    node^.RL:=NIL;
    node^.LL:=father;
    node^.Key:=chto;
    node^.Sign:=false;

    father^.LL:=node;
    father^.Sign:=true;
  end
  else begin
    curr:=father^.LL;
    while curr^.RL<>nil do
      curr:=curr^.RL;
    node^.RL:=NIL;
    node^.LL:=father;
    node^.Key:=chto;
    node^.Sign:=false;

    curr^.RL:=node;
  end;
end;

function FindNode(T:PTree;ToFind:string):PTree;
begin
    If T=NIL Then Exit;
    if T^.Key=ToFind then begin FindNode:=T; exit end
      else FindNode:=NIL;
    if T^.Sign then FindNode(T^.LL,ToFind);
    if T^.RL<>NIL then FindNode(T^.RL,ToFind);
end;

procedure ChangeNode(p:PTree;ToChange:string);
var pp: PTree;
  begin
    if FindNode(p,ToChange)<>NIL then begin
    pp:=FindNode(p,ToChange);
    pp^.Key:='node7'; end
end;

Procedure PrintDown(T:PTree;st:string);
begin
   If T = nil Then Exit;
   writeln(st+T^.key);
   if T^.Sign then PrintDown(T^.LL,St+st);
   if T^.RL<>NIL then PrintDown(T^.RL,St);
end;

procedure DeleteTree(T:PTree);
  Begin
    If T = nil Then Exit;
    if T^.Sign then DeleteTree(T^.LL);
    if T^.RL<>NIL then DeleteTree(T^.RL);
    Dispose(T);
end;

procedure DelTree(T:PTree;ToDelet:string);
var p,pp,del:PTree;
  Begin
    if FindNode(p,ToDelet)<>NIL then
       del:=FindNode(p,ToDelet);
    if del^.RL<>NIL then begin p^.RL:=del; pp:=del^.RL; end;
    DeleteTree(del);
    P^.RL:=pp;
end;

begin
s:='   ';
CreateTree(root);
AddNode('node1',root);
AddNode('node2',root);
AddNode('node3',root);
AddNode('node4',root);
AddNode('node5',root^.LL^.RL);          {это чтоб связи проверить}
ChangeNode(root,'node3');                  {просто пример}
if root<>NIL then PrintDown(root,S);
readln;
end.

[volvo]

Как я и предполагал, функция FindNode оказалась проблемной... Я немного ее изменил, вот в таком виде она вроде работает:

function FindNode(T: PTree; ToFind: string): PTree;
var p: PTree;
begin
  FindNode := nil;
  if T = nil then exit;

  if T^.Key = ToFind then begin
    FindNode := T; exit
  end;

  if T^.Sign then begin

    p := FindNode(T^.LL, ToFind);
    FindNode := p;

    if p <> nil then exit

  end;

  FindNode := FindNode(T^.RL, ToFind);
end;

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

procedure ChangeNode(p: PTree; ToChange: string);
var pp: PTree;
begin
  pp := FindNode(p, ToChange);
  if pp <> nil then begin
    pp^.Key:='node7';
  end
end;

[Jill]

Ок, с этим разобралась. Спасибо :-)
Очередные заковырки - удаление...
Удаление всего дерева расписала:

procedure DeleteTree(T:PTree);
Begin
    If T=nil Then Exit;
    if T^.Sign then DeleteTree(T^.LL);
    if T^.RL<>NIL then DeleteTree(T^.RL);
    Dispose(T);
end; 

Удаление выбранного узла (при условии, что у него нет сыновей) попыталась, но не работает Где неверно?

 procedure DeleteNode(T:PTree;ToDel:string);
var pred,posl,pp:PTree;
begin
     pp:=FindNode(T,ToDel);      {pp указывает на выбранный узел}
      if pp<>NIL then begin       {если узел найден, то...}
       if (pp^.RL<>NIL)and(pp^.LL^.LL<>pp)then {если узел - "средний" брат}
         begin
           pred:=pp^.LL^.LL;         {находим "старшего" брата найденного узла}
             while pred^.RL<>pp do
             pred:=pred^.RL;         {продвигаемся по правой ветви пока не нашли предшествующий узел}
             posl:=pp^.RL;         {определяем последующий узел}
             pred^.RL:=posl;       {перераспределяем связи}
            dispose(pp);            {удаляем выбранный}
         end
       else
        if pp^.RL=NIL then   {если узел - "младший" брат}
         dispose(pp)
       else
        if (pp^.RL<>NIL)and(pp^.LL^.LL=pp) then   {если узел - "старший" брат}
          begin
           pred:=pp^.LL;    {отец выбранного узла}
           posl:=pp^.RL;    {следующий за выбранным брат}
           pred^.LL:=posl;  {перераспределяем связи}
           dispose(pp);
          end;
       end;
end; 

И еще. Как связать эти две процедуры, чтобы удалить узел, у которого есть сыновья/поддеревья? Удалить вместе с ними? Как? Тут я вообще сориентироваться не могу

[volvo]

Jill, с удалением одного элемента у тебя проблема - дело в том, что если у узла есть потомок (Sign = True), то НИГДЕ не хранится адрес предка этого узла. Смотри сама: в RL хранится указатель на "братьев", а в LL - указатель на потомка. Как найти предка?

Единственное решение, которое будет работать и для Sign = True и для Sign = False: Проходить еще раз по всему дереву, и искать узел, содержимое RL (или LL при Sign=True) которого равняется адресу элемента, который ты нашла здесь:

  pp:=FindNode(T, ToDel);

только так ты можешь гарантированно найти предка PP.

[Jill]

Написала функцию поиска предыдущего элемента. Что-то длинноватая получилась, но работает:

 function FindPreceding(T,pp:PTree):PTree;   {pp - найденный узел}
var p:PTree;
begin
  FindPreceding:=nil;
  if T=nil then exit;
  if T^.RL=pp then
    begin
      FindPreceding:=T; exit;
    end;
  if (T^.Sign) and (T^.LL=pp) then
    begin
      FindPreceding:=T; exit;
    end;
  if T^.Sign then
    begin
      p:=FindPreceding(T^.LL,pp);
      FindPreceding:=p;
        if p<>NIL then exit;
    end;
  if T^.RL<>NIL then
    begin p:=FindPreceding(T^.RL,pp);
      FindPreceding:=p;
        if p<>NIL then exit;
    end;
end;  

Теперь удаление:

 procedure DeleteNode(T:PTree;ToDel:string);
var pred,posl,p:PTree;
begin
     p:=FindNode(T,ToDel);      {p указывает на выбранный узел}
      if p<>NIL then begin      {если узел найден, то...}

       if p^.LL=NIL then
          begin
            DeleteTree(p); {найденный узел - корень дерева}
            exit;
          end;

       pred:=FindPreceding(root,p);
       if p^.Sign then         {удаление поддерева без выбранного узла}
        begin
          posl:=p^.LL;         {?как быть с левым указателем?}
          DeleteTree(posl);
       end;

       if p^.RL=NIL then   {если узел не имеет "младших" братьев}
          begin
            pred^.RL:=NIL;
            dispose(p)
          end
       else
        if p^.RL<>NIL then  {если узел имеет "младшего" брата}
          begin
             if pred^.RL=p then    {если предыдуший узел - "старший" брат}
                begin
                  posl:=p^.RL;
                  pred^.RL:=posl;
                  dispose(p);
                end;
             if (pred^.Sign)and(pred^.LL=p) then   {если предыдуший узел - отец}
                begin
                  posl:=p^.RL;
                  pred^.LL:=posl;
                  dispose(p);
                end;
           end;
       end;
end;

Сообщение отредактировано: volvo - 25.11.2010 19:55

[volvo]

По просьбе Jill зашел в этот топик , и сразу вопрос на засыпку: а почему именно левопрошитое дерево? Есть какие-то преимущества его перед правопрошитым? Или перед AVL? Кстати, та структура, которую ты привела, не имеет никаких преимуществ перед N-арным деревом (когда-то было написано мной и такое, могу покопаться и найти исходники), а вот мороки с ней сама видишь, насколько больше...