Версия для печати темы

Нажмите сюда для просмотра этой темы в обычном формате

Форум «Всё о Паскале» _ Задачи _ Бинарное дерево-уход в бесконечный циклр

Автор: Pessimist 22.01.2009 7:03

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

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

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

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


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


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 7:55

У тебя в программе 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 22.01.2009 8:11

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

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

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

Автор: volvo 22.01.2009 18:29

Возможно, я уже опоздал, но вот что получилось (переписаны все твои функции/процедуры; объяснение, почему удаление элемента желается именно так приведено http://volvo71.narod.ru/faq_folder/bin_tree.htm#bintree_delnode , там же можешь найти и другую полезную информацию о работе с деревьями):

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.