Прошивка дерева согласно обратному обходу - Pascal ABC
Формулировка задачи:
Помогите, пожалуйста, решением задачи, очень нужно!
Общее задание:
Реализовать следующие функции для работы с деревом поиска:
1. Добавление нового узла.
2. Удаление узла.
3. Сохранение данных в типизированный файл.
4. Построение дерева поиска из типизированного файла.
5. Вывод дерева на экран в графическом виде.
Само задание:
Реализовать дерево массивом. Написать программу прошивки дерева согласно обратному обходу. Определить, является ли узел со значением m предком узла n.
Решение задачи: «Прошивка дерева согласно обратному обходу»
textual
Листинг программы
uses
Crt, SysUtils;
const
n=8;
m=100;
type
Node=record
ex:Boolean;
info:Integer;
left:Integer;
right:Integer;
end;
Tree=array [1..m] of Node;
Mas=array [1..m] of Integer;
var
BTree:Tree;
ch:Char;
menu:array [1..n] of String [100];
A:Mas;
punkt,x,y:Integer;
procedure ShowMenu;
var
i:Integer;
begin
ClrScr;
WriteLn ('Вас приветствует программа для работы с "Бинарным деревом поиска"');
WriteLn ('Для работы в программе используйте клавиши "вверх" и "вниз" для перемещения по пунктам. Для выбора пункта нажмите клавишу Enter. Для выхода из программы нажмите клавишу Esc.');
for i:=1 to n do
begin
GoToXY (x,y+i-1);
Write (menu[i]);
end;
TextColor (red);
GoToXY (x,y+punkt-1);
Write (menu[punkt]);
end;
procedure InsertElement (e,k:Integer);
var
i:Integer;
begin
if not BTree[1].ex then
begin
BTree[1].ex:=true;
BTree[1].info:=e;
BTree[1].left:=0;
BTree[1].right:=0;
end
else
begin
if e<BTree[k].info then
if BTree[k].left=0 then
begin
for i:=2 to m do
if BTree[i].ex=false then
begin
BTree[k].left:=i;
BTree[i].ex:=true;
BTree[i].info:=e;
BTree[i].left:=0;
BTree[i].right:=0;
Exit;
end;
end
else
InsertElement (e,BTree[k].left)
else
if BTree[k].right=0 then
begin
for i:=2 to m do
if BTree[i].ex=false then
begin
BTree[k].right:=i;
BTree[i].ex:=true;
BTree[i].info:=e;
BTree[i].left:=0;
BTree[i].right:=0;
Exit;
end;
end
else
InsertElement (e,BTree[k].right);
end;
end;
function FindElement (e:Integer; d:Boolean; var A:Mas):Integer;
var
way:String;
b,c,i,j:Integer;
begin
j:=1;
for i:=1 to m do
if BTree[i].ex then
if BTree[i].info=e then
begin
A[j]:=i;
j:=j+1;
end;
i:=j-1;
FindElement:=A[1];
if A[1]<>0 then
begin
for j:=1 to i do
if A[j]<>0 then
begin
e:=A[j];
c:=e;
way:=IntToStr (BTree[A[j]].info);
b:=1;
while c<>1 do
while b<>m do
begin
if ((BTree[b].left=c) or (BTree[b].right=c)) and (BTree[b].ex) then
begin
way:=Concat (IntToStr (BTree[b].info),'-',way);
c:=b;
b:=0;
end;
b:=b+1;
end;
if d then
WriteLn ('Индекс искомого элемента равен: ',e,' ',way);
end;
end
else
if d then
WriteLn ('Искомый элемент не найден!');
end;
procedure DeleteElement (k:Integer);
var
a,b,c,i:Integer;
begin
if BTree[k].right<>0 then
begin
a:=BTree[k].right;
repeat
b:=a;
a:=BTree[a].left;
until a=0;
a:=b;
BTree[b].left:=BTree[k].left;
repeat
c:=b;
b:=BTree[b].right;
until b=0;
BTree[c].right:=BTree[k].right;
BTree[a].ex:=false;
BTree[k].info:=BTree[a].info;
BTree[k].right:=BTree[a].right;
BTree[a].left:=0;
BTree[a].right:=0;
for i:=1 to m do
if (BTree[i].left=a) or (BTree[i].right=a) then
if BTree[i].left=a then
BTree[i].left:=0
else
BTree[i].right:=0;
end
else
if BTree[k].left<>0 then
begin
a:=BTree[k].left;
BTree[a].ex:=false;
BTree[k].info:=BTree[a].info;
BTree[k].left:=BTree[a].left;
BTree[k].right:=BTree[a].right;
BTree[a].left:=0;
BTree[a].right:=0;
end
else
begin
BTree[k].ex:=false;
for i:=1 to m do
if (BTree[i].left=k) or (BTree[i].right=k) then
if BTree[i].left=k then
BTree[i].left:=0
else
BTree[i].right:=0;
end;
end;
procedure DeletePart (k:Integer);
begin
if k=0 then
Exit;
BTree[k].ex:=false;
DeletePart (BTree[k].left);
DeletePart (BTree[k].right);
end;
procedure WriteElement (a,b,c,d,e:Integer);
begin
if not (BTree[d].ex) then
begin
e:=e-1;
Exit;
end;
if e=5 then
begin
e:=e-1;
Exit;
end;
GoToXY (a,b);
e:=e+1;
Write (BTree[d].info);
if (BTree[d].left<>0) then
WriteElement (a-c,b+2,c div 2,BTree[d].left,e);
if (BTree[d].right<>0) then
WriteElement (a+c,b+2,c div 2,BTree[d].right,e);
end;
procedure CreateTree (a:Boolean);
var e,i,n:Integer;
v:Char;
begin
ClrScr;
if BTree[1].ex then
begin
WriteLn ('Дерево уже создано!');
ReadLn;
end
else
begin
if a then
begin
WriteLn ('Дерево ещё не создано. Вы желаете создать его? (Да/Нет) (Введите заглавную букву): ');
ReadLn (v);
if not (v in ['Д','д']) then
Exit;
end;
WriteLn ('Введите количество элементов (не более ',m,') : ');
ReadLn (n);
while (n>m) or (n<0) do
begin
WriteLn ('Ошибочный ввод! Введите заново количество элементов (не более ',m,') : ');
ReadLn (n);
end;
WriteLn ('Вводите элементы, первый элемент будет корнем дерева: ');
for i:=1 to n do
begin
ReadLn (e);
InsertElement (e,1);
end;
end;
end;
procedure InsertElementInTree;
var
b,e,i,n:Integer;
begin
ClrScr;
if not (BTree[1].ex) then
CreateTree (true)
else
begin
b:=0;
for i:=1 to m do
if BTree[i].ex then
b:=b+1;
WriteLn ('Введите количество элементов (не более ',m-b,' ) : ');
ReadLn (n);
while (n>(m-b)) or (n<0) do
begin
WriteLn ('Ошибочный ввод! Введите заново количество элементов (не более ',m-b,' ) : ');
ReadLn (n);
end;
WriteLn ('Вводите элементы: ');
for i:=1 to n do
begin
ReadLn (e);
InsertElement (e,1);
end;
end;
end;
procedure FindElementOfTree;
var
i,e:Integer;
begin
ClrScr;
if not (BTree[1].ex) then
CreateTree (true)
else
begin
WriteLn ('Введите элемент: ');
ReadLn (e);
for i:=1 to m do
A[i]:=0;
FindElement (e,true,A);
ReadLn;
end;
end;
procedure DeleteElementOfTree;
var
e,i,j,k,l,n:Integer;
v:Char;
begin
ClrScr;
l:=0;
if not (BTree[1].ex) then
CreateTree (true)
else
begin
WriteLn ('Введите элемент: ');
ReadLn (e);
j:=0;
for i:=1 to m do
if BTree[i].ex then
if BTree[i].info=e then
j:=j+1;
if j<2 then
begin
for i:=1 to m do
A[i]:=0;
k:=FindElement (e,false,A);
if k<>0 then
begin
DeleteElement (k);
WriteLn ('Элемент удалён');
end
else
WriteLn ('Удаляемый элемент не найден!');
end
else
begin
WriteLn ('Данных элементов в дереве несколько. Вы хотите удалить их все? (Да/Некоторые/Передумал удалять) (Введите заглавную букву): ');
ReadLn (v);
if not (v in ['Д','д','Н','н']) then
Exit;
if (v in ['Д','д']) then
begin
repeat
for i:=1 to m do
A[i]:=0;
k:=FindElement (e,false,A);
if k<>0 then
DeleteElement (k);
until k=0;
WriteLn ('Элементы удалены');
end
else
begin
for i:=1 to m do
A[i]:=0;
FindElement (e,false,A);
WriteLn ('Индексы искомого элемента равны: ');
for i:=1 to m do
if A[i]<>0 then
begin
Write (A[i],' ');
l:=l+1;
end;
WriteLn;
WriteLn ('Введите количество тех элементов, которые хотите удалить, а затем их индексы: ');
ReadLn (k);
while (k>l) or (k<0) do
begin
WriteLn ('Ошибочный ввод! Введите еще раз: ');
ReadLn (k);
end;
repeat
i:=k;
ReadLn (n);
for j:=1 to m do
if (A[j]=n) and (n<>0) then
begin
DeleteElement (n);
k:=k-1;
end;
if i=k then
WriteLn('Ошибочный ввод! Индекс находится не среди удаляемых элементов! Введите еще раз:');
until k=0;
WriteLn ('Элементы удалены');
end;
end;
ReadLn;
end;
end;
procedure DeletePartOfTree;
var
e,i,j,k,l,n:Integer;
v:Char;
begin
ClrScr;
l:=0;
if not (BTree[1].ex) then
CreateTree (true)
else
begin
WriteLn ('Введите вершину удаляемого поддерева: ');
ReadLn(e);
j:=0;
for i:=1 to m do
if BTree[i].ex then
if BTree[i].info=e then
j:=j+1;
if j<2 then
begin
for i:=1 to m do
A[i]:=0;
k:=FindElement (e,false,A);
if k<>0 then
begin
DeletePart (k);
WriteLn ('Поддерево удалено');
end
else
WriteLn ('Удаляемое поддерево не найдено!');
end
else
begin
WriteLn ('Данных элементов в дереве несколько. Вы хотите удалить их все? (Да/Некоторые/Передумал удалять) (Введите заглавную букву): ');
ReadLn (v);
if not (v in ['Д','д','Н','н']) then
Exit;
if not (v in ['Н','н']) then
begin
repeat
for i:=1 to m do
A[i]:=0;
k:=FindElement (e,false,A);
if k<>0 then
DeletePart (k);
until (k=0);
WriteLn ('Элементы удалены');
end
else
begin
for i:=1 to m do
A[i]:=0;
FindElement (e,false,A);
WriteLn ('Индексы искомого элемента равны: ');
for i:=1 to m do
if A[i]<>0 then
begin
Write (A[i],' ');
l:=l+1;
end;
WriteLn;
WriteLn ('Введите количество тех элементов, которые хотите удалить, а затем их индексы: ');
ReadLn (k);
while (k>l) or (k<0) do
begin
WriteLn ('Ошибочный ввод! Введите еще раз: ');
ReadLn (k);
end;
repeat
i:=k;
ReadLn (n);
for j:=1 to m do
if (A[j]=n) and (n<>0) then
begin
DeletePart (n);
k:=k-1;
end;
if i=k then
WriteLn('Ошибочный ввод! Индекс находится не среди удаляемых элементов! Введите еще раз:');
until k=0;
WriteLn ('Поддеревья удалены');
end;
end;
ReadLn;
end;
end;
procedure DeleteFullTree;
var
i:Integer;
begin
ClrScr;
if not (BTree[1].ex) then
CreateTree (true)
else
begin
for i:=1 to m do
BTree[i].ex:=false;
WriteLn ('Дерево удалено');
ReadLn;
end;
end;
procedure ShowTree;
var
d,i:Integer;
MessageStr:AnsiString;
begin
ClrScr;
MessageStr:='Возможно, вы видите лишь часть дерева. Нажмите стрелочку влево, чтобы увидеть левое поддерево данного корня, стрелочку вправо, чтобы увидеть правое поддерево данного корня, стрелочку вверх, чтобы увидеть поддерево родителя данного корня, Enter, чтобы выйти.';
d:=1;
if BTree[1].ex then
begin
WriteLn (MessageStr);
WriteElement (80,25,28,d,0);
repeat
ch:=ReadKey;
ClrScr;
WriteLn (MessageStr);
if ch=#80 then
WriteElement (80,25,28,d,0);
if ch=#72 then
begin
for i:=1 to m do
if BTree[i].ex then
if (BTree[i].left=d) or (BTree[i].right=d) then
begin
ClrScr;
WriteLn (MessageStr);
d:=i;
WriteElement (80,25,28,d,0);
Break;
end
else
WriteElement (80,25,28,d,0);
end;
if ch=#75 then
begin
if BTree[d].left<>0 then
d:=BTree[d].left;
ClrScr;
WriteLn (MessageStr);
WriteElement (80,25,28,d,0);
end;
if ch=#77 then
begin
if BTree[d].right<>0 then
d:=BTree[d].right;
ClrScr;
WriteLn (MessageStr);
WriteElement (80,25,28,d,0);
end;
until ch=#13;
end
else
CreateTree (true);
end;
begin
TextBackground(white);
menu[1]:='Создать дерево';
menu[2]:='Добавить в дерево элементы';
menu[3]:='Найти элемент';
menu[4]:='Удалить элемент';
menu[5]:='Удалить поддерево ';
menu[6]:='Удалить дерево';
menu[7]:='Вывести текущее состояние дерева на экран';
menu[8]:='Выход из программы';
punkt:=1;
x:=70;
y:=25;
TextColor (lightblue);
ShowMenu;
repeat
ch:=ReadKey;
if ch=#0 then
begin
ch:=ReadKey;
if ch=#80 then
if punkt<n then
begin
TextColor (lightblue);
GoToXY (x,y+punkt-1);
Write (menu[punkt]);
punkt:=punkt+1;
TextColor (red);
GoToXY (x,y+punkt-1);
Write (menu[punkt]);
TextColor (lightblue);
end;
if ch=#72 then
if punkt>1 then
begin
TextColor (lightblue);
GoToXY (x,y+punkt-1);
Write (menu[punkt]);
punkt:=punkt-1;
TextColor (red);
GoToXY (x,y+punkt-1);
Write (menu[punkt]);
TextColor (lightblue);
end;
end
else
if ch=#13 then
begin
TextColor (lightblue);
case punkt of
1:CreateTree(false);
2:InsertElementInTree;
3:FindElementOfTree;
4:DeleteElementOfTree;
5:DeletePartOfTree;
6:DeleteFullTree;
7:ShowTree;
8:ch:=#27;
end;
ShowMenu;
end;
until ch=#27;
end.
Объяснение кода листинга программы
The code you provided is written in Pascal ABC and it seems to be a program that allows users to create, insert, find, delete, and display trees. It also includes options to delete parts or whole trees. However, the code does not include any comments or documentation, which makes it difficult to understand the purpose and functionality of the program. Additionally, the code uses a few outdated and non-standard functions, such as ReadLn and WriteLn, which may not work as expected on modern operating systems. It would be best to update the code to use more modern and compatible functions and add comments to make it easier to understand.
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д