Бинарное дерево-уход в бесконечный циклр, 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]

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

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.