Бинарное дерево-уход в бесконечный циклр, Stack overflow error Опции

[Pessimist]

Англо-русский словарь построен как бинарный список (двоичное
дерево).
Каждая компонента содержит английское слово, соответствующее
ему русское слово и счетчик количества обращений к данной компонен-
те.
Первоначально бинарный список был сформирован согласно английс-
кому алфавиту. В процессе эксплуатации словаря при каждом обращении
к компоненте в счетчик обращений добавлялась единица.

Составить программу, которая:
-обеспечивает начальный ввод словаря с конкретными значениями
счетчиков обращений;
-формирует новое представление словаря в виде двоичного дерева
по следующему алгоритму:
а) в старом словаре ищется компонента с наибольшим значением
счетчика обращений;
б) найденная компонента заносится в новый словарь и удаляется
из старого;
в) переход к п. а) до исчерпания исходного словаря.

-производит распечатку исходного и нового словарей.

Указание: использовать динамические структуры.


КОД ПРОГРАММЫ:

program dynamic;
uses crt;
type rec = record
          num : word;
          eng : string;
          rus : string;
     end;
     pnode = ^node;
     node = record
         data : rec;
         left : pnode;
         right: pnode;
     end;
var root,rootnew  :pnode;
    key   :string;
    option,temp:word;
    rec1:rec;
F,Fresult:text;


procedure print_tree(p:pnode);
begin
     if p=nil then exit;
     with p^ do begin
          print_tree(right);
          write(data.eng,'    ', data.rus,'    ', data.num);
          writeln;
          write(Fresult, data.eng,'    ', data.rus,'    ', data.num);
          writeln(Fresult);
          print_tree(left);
     end
end;

function find(root:pnode; key:string; var p,parent:pnode): boolean;
begin
     p:=root;
     while p<>nil do begin
           if key=p^.data.eng then
              begin find:=true; exit end;
           parent:=p;
           if key< p^.data.eng
              then p:=p^.left
              else p:=p^.right;
           end;
           find:=false;
end;

procedure insert(var root : pnode; rec1:rec);
var p1,parent : pnode;
begin
     if find(root, rec1.eng, p1,parent) then begin
     writeln('takoi element uzhe est'); exit; end;
     new(p1);
     p1^.data :=rec1;
     p1^.left :=nil;
     p1^.right:=nil;
     if root = nil then root :=p1
     else
         if rec1.eng < parent^.data.eng
         then parent^.left :=p1
         else parent^.right :=p1;
end;

procedure del(var root:pnode;key:string);
var p      :pnode;
    parent :pnode;
    y      :pnode;

function descent(p:pnode):pnode;
var y:pnode;
    prev:pnode;
begin
     y:=p^.right;
     if y^.left = nil then y^.left:=p^.left
     else begin
          repeat
                prev:=y;y:=y^.left;
          until y^.left =nil;
          y^.left:=p^.left;
          prev^.left:=y^.right;
          y^.right:=p^.right;
     end;
     descent:=y;
end;

begin
     if not find(root, key,p,parent) then begin
        writeln('takogo el-ta net'); exit; end;
     if      p^.left = nil then y:=p^.right
     else if p^.right = nil then y:=p^.left
     else    y:=descent(p);
     if p=root then root:=y
     else
         if key < parent^.data.eng
            then parent^.left:=y
            else parent^.right:=y;;
     dispose(p);
end;

{-------------------------------------}
function max(p:pnode) : word;
var m:word;
begin
if p=nil then begin max:=0; exit end;
if ( max(p^.left) <= max(p^.right)) then
m:=max(p^.right)
else m:=max(p^.left);
if p^.data.num>m then max:=p^.data.num
else max:=m;
end;
{-------------------------------------}
function findmax(p:pnode;max:word) : pnode;
begin
     if p=nil then exit;
     with p^ do begin
     if findmax(left,max) <> nil then
     begin findmax:=findmax(left,max); exit end
     else if findmax(right,max) <>nil then
     begin findmax:=findmax(right,max); exit end
     else if data.num=max then
     begin findmax:=p; exit end
     else findmax:= nil;
     end;
end;
{-------------------------------------}

procedure move(p,pnew:pnode);
var m:word;
    p2:pnode;
    i:integer;
begin
if p=nil then exit;
for i:=1 to 3 do
begin
m:=max(p);
p2:=findmax(p,m);
writeln(p2^.data.eng);
insert(pnew,p2^.data);
del(p,p2^.data.eng);
move(p,pnew);
end;
end;




begin
root:=nil;
rootnew:=nil;
Assign(F, '15_10_in.txt');
reset(F);
   while eof(F)=false do begin
         with rec1 do begin
         readln(F, num);
         readln(F, eng);
         readln(F, rus);
         end;
         insert(root, rec1)

   end;
close(F);
assign(Fresult, '15_10_out.txt');
rewrite(Fresult);
print_tree(root);
move(root,rootnew);
close(Fresult)
end.

при попытке компиляции выдает Stack overflow error сам ошибку найти не смог, а прогу позарез к утру сделать нуна.

Очччень нуна помощщщьь

Тегами пользуйся, без них программа нечитаема абсолютно

Сообщение отредактировано: volvo - 22.01.2009 3:27

[volvo]

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

function findmax(p:pnode; max:word) : pnode;
begin
     if p=nil then findmax:=nil
     else
       if p^.data.num = max then findmax := p
       else
         if max < p^.data.num then findmax := findmax(p^.left, max)
         else findmax := findmax(p^.right, max);
end;

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

procedure move(p,pnew:pnode);
var m:word;
    p2:pnode;
    i:integer;
begin
  if p=nil then exit;
  for i:=1 to 3 do
  begin
    m:=max(p); { <--- допустим, ты уже выбрал все из словаря, p = nil }
    p2:=findmax(p,m); { <--- Тогда и здесь будет p2 = nil }
    writeln(p2^.data.eng); { <--- Стоп!!! }
    insert(pnew,p2^.data);
    del(p,p2^.data.eng);
    move(p,pnew);
  end;
end;

Тебе ж все равно надо работать до исчерпания исходного словаря? Тогда каким боком там рекурсия: Удаляй по одному элементу из дерева, пока его корень не станет нулевым:

procedure move(p,pnew:pnode);
var m:word;
    p2:pnode;
begin
repeat
  m:=max(p);
  p2:=findmax(p,m);
  if p <> nil then begin
    writeln(p2^.data.eng);
    insert(pnew,p2^.data);
    del(p,p2^.data.eng);
  end;
  until p = nil;
end;

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

[Pessimist]

спс пошел мучать её дальше.

Добавлено через 6 мин.
Так насчет findmax() не согласен, если учитывать, что дерево создается по data.eng следовательно поиск по data.num может быть ток перебором элементов до первого совпадения

Добавлено через 13 мин.
Не могли бы вы проверить функцию find().
похоже из-за неё возникает зацикливание.

[volvo]

Возможно, я уже опоздал, но вот что получилось (переписаны все твои функции/процедуры; объяснение, почему удаление элемента желается именно так приведено здесь , там же можешь найти и другую полезную информацию о работе с деревьями):

program dynamic;
uses crt;
type
  rec = record
    num: word;
    eng: string;
    rus: string;
  end;
  pnode = ^node;
  node = record
    data : rec;
    left : pnode;
    right: pnode;
  end;

var
  F, Fresult: text;

procedure print_tree(p:pnode);
begin
  if p = nil then exit;
  with p^ do begin
    print_tree(right);

    write(data.eng,'    ', data.rus,'    ', data.num);
    writeln;
    write(Fresult, data.eng,'    ', data.rus,'    ', data.num);
    writeln(Fresult);

    print_tree(left);
  end
end;

procedure insert(var root: pnode; R: rec);

  procedure create_node(var p: pnode);
  begin
    New(p);
    p^.data := R;
    p^.Left := nil;
    p^.Right := nil
  end;

begin
  if root = nil then create_node(root)
  else
    with root^ do begin
      if data.eng < R.eng then insert(right, R)
      else
        if data.eng > R.eng then insert(left, R)
        else writeln('takoi element uzhe est"');
    end;
end;

procedure remove(var root: pnode; value: integer);

  procedure DeleteMin(var Root: pnode; var T: rec);
  var WasRoot: pnode;
  begin
    if Root^.Left = nil then begin
      T := Root^.data;
      WasRoot := Root;
      Root := Root^.Right;
      Dispose(WasRoot);
    end
    else DeleteMin(Root^.Left, T);
  end;

var
  WasNext: pnode;
  R: rec;

begin
  if Root <> nil then
    if Root^.data.num <> value then begin
      Remove(Root^.Left, value); Remove(Root^.right, value);
    end
    else
      if (Root^.Left = nil) and (Root^.Right = nil) then begin
        Dispose(Root); Root := nil
      end
      else
        if Root^.Left = nil then begin
          WasNext := Root^.Right;
          Dispose(Root);
          Root := WasNext;
        end
        else
          if Root^.Right = nil then begin
            WasNext := Root^.Left;
            Dispose(Root);
            Root := WasNext;
          end
          else begin
            DeleteMin(Root^.Right, R);
            Root^.data := R
          end;
end;


function max_value(r: pnode): pnode;
var
  found: pnode;

  procedure find_max(r: pnode);
  begin
    if r = nil then exit
    else begin
      if found^.data.num < r^.data.num then found := r;
      find_max(r^.left); find_max(r^.right);
    end;
  end;

begin
  if r = nil then max_value := nil
  else begin
    found := r;
    find_max®;
    max_value := found;
  end;
end;


procedure move(p,pnew:pnode);
var p_max: pnode;
begin
  repeat
    p_max := max_value(p);
    if p_max <> nil then begin
      writeln(p_max^.data.eng);
      insert(pnew, p_max^.data);
      remove(p, p_max^.data.num);
    end;
  until p = nil;
end;

var
  root, rootnew: pnode;
  rec1: rec;

begin
  root:=nil; rootnew:=nil;

  Assign(F, '15_10_in.txt');
  reset(F);
  while not eof(F) do begin
    with rec1 do begin
      readln(F, num);
      readln(F, eng);
      readln(F, rus);
    end;
    insert(root, rec1);
  end;
  close(F);

  assign(Fresult, '15_10_out.txt');
  rewrite(Fresult);
  print_tree(root);
  move(root,rootnew);
  close(Fresult)
end.