function InsertKey(x:integer;T:TTree):TTree;
var i,j,D:integer;
begin
if T=nil then
begin
new(T);
T^.count:=1;
T^.isLeave:=true;
SetLength(T^.keys,1);
T^.keys[0].key:=x;
T^.keys[0].kid:=nil;
Root:=T;
end
else
begin
if T^.keys[T^.count-1].key=MAX then
D:=2*Degree
else
D:=2*Degree-2;
if T^.count>D then
begin
T:= Split(T);
result:=InsertKey(x,Root)
end
else
begin
i:=0;
while (x>T^.keys[i].key)and(i<T^.count) do inc(i);
if x<>T^.keys[i].key then
begin
if i<T^.count then //insert to middle or start
begin
if (T^.keys[i].kid<>nil)then
result:=InsertKey(x,T^.keys[i].kid)
else
begin
T^.Count:=T^.count+1;
SetLength(T^.keys,T^.count);
for j:=T^.count-1 downto i+1 do
T^.keys[j]:=T^.keys[j-1];
T^.keys[i].key:=x;
T^.keys[i].kid:=nil;
end;
end
else //insert to end
if i=T^.count then
begin
T^.count:=T^.count+1;
SetLength(T^.keys,T^.count);
T^.keys[i].key:=x;
T^.keys[i].kid:=nil;
end;
end;
end;
end;
result:=T;
end;
procedure PrintTree(Tree:TTree;Pos:integer); //вывод дерева ПКЛ обходом
var i,j:integer;
begin
if Tree<>nil then
begin
i:=Tree^.Count-1;
while(i>=0)do
begin
if Tree^.keys[i].key<MAX then
begin
for j:=1 to Pos do write(' ');
writeln(Tree^.keys[i].key);
end;
if Tree^.keys[i].kid<>nil then PrintTree(Tree^.keys[i].kid,Pos+5);
i:=i-1;
end;
end;
end;
procedure Reorganize(var Tree:TTree); //перестроение дерева
var s:array of integer;
i:integer;
procedure ReBuildTree(Tree:TTree); //построение нового на основе
var i:integer; //старого без удаляемого
begin
if Tree<>nil then
begin
i:=Tree^.Count-1;
while(i>=0)do
begin
if Tree^.keys[i].key<MAX then
begin
setlength(s,length(s)+1);
s[length(s)-1]:=Tree^.keys[i].key;
end;
write('.');
sleep(10);
if Tree^.keys[i].kid<>nil then ReBuildTree(Tree^.keys[i].kid);
i:=i-1;
end;
end;
end;//get tree
begin
writeln;
writex('Производим реорганизацию дерева...');
setlength(s,0);
ReBuildTree(Tree);
writeln;
Tree:=TerminateTree(Tree);
for i:=0 to length(s)-1 do
Tree:=InsertKey(s[i],Tree);
writeln;
writelnx('Дерево реорганизовано!');
writeln;
end;
var M1,M2:byte;
i,j,MaxG,k,c,n:integer;
R:boolean; //флаг реорганизации при удалении
S:TTree; //для поиска
begin
// writeln(' ----------- ');
writelnx('| Б-деревья |');
// writeln(' ----------- ');
writeln;
repeat
writelnx('Выберите пункт меню:');
//writeln('^^^^^^^^^^^^^^^^^^^^');
writelnx(' 1) Создание Б-дерева');
writelnx(' 2) Просмотр дерева');
//writelnx(' 3) Поиск в Б-дереве');
writelnx(' 4) Изменение дерева');
//writelnx(' 5) Выход (0-помощь)');
write(' : ');
readln(M1);
case M1 of
0:begin
writelnx(Help);
writelnx('Нажмите <Enter>...');
readln;
end;
1:begin
repeat
writeln;
writelnx('Создание Б-дерева:');
writelnx(' 1) Случайными числами');
writelnx(' 2) Ввод элементов вручную');
writex(' 3) Изменить степень (текущая T=');writeln(Degree,')');
// writelnx(' 4) Возврат');
write(' : ');
readln(M2);
if (M2>0) and (M2<4) then Root:=TerminateTree(Root);
case M2 of
1:begin
writex('Введите желаемое количество элементов (узлов) Б-дерева:');
readln(MaxG);
// writex('Процесс создания отследить (1-да, 2-нет)? ');
// readln(j);
j:=2;
randomize;n:=0;
for i:=1 to MaxG do
begin
c:=random(1000);
if (j=1) then begin writex('Подаем >>> ');writeln(c); end;
if Root<>nil then
begin
if Search(c,Root,k)=nil then
Root:=InsertKey(c,Root)
else
begin
if j=1 then writelnx('Такое значение уже пристутствует в дереве!')
else n:=n+1
end
end
else Root:=InsertKey(c,Root);
if (j=1) then
begin
writex('нажмите ввод...');readln;
writelnx('Б - ДЕРЕВО');
PrintTree(Root,3);
// writelnx('---------------------------------------------------');
end;
end;
if j<>1 then writelnx('Повторилось '+IntToStr(n)+' значений');
writelnx('Дерево готово.');
end;
2:begin
writelnx('Вводите числа одно за одним через пробел или <Enter>.');
writelnx('По окончании - введите -1');
read(j);
while (j<>-1) do
begin
if Root=nil then Root:=InsertKey(j,Root) else
if Search(j,Root,c)=nil then
Root:=InsertKey(j,Root)
else
writelnx('Есть уже такое значение');
writelnx('Б - ДЕРЕВО');
PrintTree(Root,3);
//writelnx('---------------------------------------------------');
read(j);
end;
writelnx('Дерево готово');
end;
3:begin
writelnx('Изменение минимальной степени дерева:');
writex('Введите новое значение(текущее T=');write(Degree,'): ');
readln(Degree);
end;
end;
until M2<>3;
end;
2:if Root=nil then writelnx('>>>>>>>>>>>>>>>>> Дерево не создано!') else
begin
writelnx('-------------------Б - ДЕРЕВО----------------------');
PrintTree(Root,3);
//writelnx('---------------------------------------------------');
end;
3:if Root=nil then writelnx('>>>>>>>>>>>>>>>>> Дерево не создано!') else begin
writex('Введите искомое значение: ');readln(j);
S:=Search(j,Root,i);
if S<>nil then
begin
writelnx('Элемент найден!');
writex('Значение: ');writeln(S^.keys[i].key);
if S^.keys[i].kid<>nil then
begin
writelnx('Потомки:');
PrintTree(S^.keys[i].kid,3);
end else
writelnx('Потомков нет у данного элемента');
end else writelnx('Нет такого значения!');
end;
4:if Root=nil then writelnx('>>>>>>>>>>>>>>>>> Дерево не создано!') else begin
repeat
writelnx('Выберите пункт меню:');
writelnx('1) Вставка');
writelnx('2) Удаление');
writelnx('3) Возврат');
write(' : ');
readln(j);
case j of
1:begin
writelnx('Вводите ключи(числа менее '+IntToStr(MAX)+') (-1 - завершить ввод):');
readln(k);
while(k<>-1)do
begin
if Root=nil then Root:=InsertKey(k,Root) else
if Search(k,Root,c)=nil then
Root:=InsertKey(k,Root)
else writelnx('Есть уже такое значение');
writeln;
writelnx('-------------------Б - ДЕРЕВО----------------------');
PrintTree(Root,3);
writelnx('---------------------------------------------------');
writelnx('Еще? (-1 - конец)');
readln(k);
end;
j:=3;
end;
2:
begin
writex('Введите значение для удаления: ');
readln(k);
S:=Search(k,Root,i);
if S<>nil then
begin
Root:=DeleteFromTree(k,Root,R);
if R then
Reorganize(Root);
writeln;
writelnx('-------------------Б - ДЕРЕВО----------------------');
PrintTree(Root,3);
writelnx('---------------------------------------------------');
writelnx('Элемент успешно удален!');
end
else writelnx('Элемент не найден!');
j:=3;
end;
end;//case
until j=3;
end;
end;
until M1=5;
Root:=TerminateTree(Root);
end.