program another;
{$APPTYPE CONSOLE}
uses
SysUtils,
Windows;
//константы
const MAX=9999;
Help='Б-деревом (B-Tree) называется дерево, устроенное следующим образом:'+#13#10+
' 1) Каждая вершина содержит поля, в которых хранятся: количество n ключей,'#13#10+
' содержащихся в ней, сами ключи в неубывающем порядке и булевское значе-'#13#10+
' ние, истинное, когда вершина является листом. Внутренние вершины кроме'#13#10+
' того содержат n+1 указателей на её детей. У листьев детей нет, так что'#13#10+
' эти поля для них не определены.'#13#10+
' 2) Ключи, очевидно, служат границами, разделяющими значения ключей в под-'#13#10+
' деревьях.'#13#10+
' 3) Все листья находятся на одной глубине, называемой высотой дерева.'#13#10+
' 4) Число ключей, хранящихся в одной вершине, ограничено и сверху, и снизу.'#13#10+
' Границы задаются единым для всего дерева числом T>2, которое называется'#13#10+
' минимальной степенью (minimum degree) Б-дерева. При этом каждая вершина,'#13#10+
' кроме корня,содержит не менее T-1 и не более 2T-1 ключей. Соответственно,'#13#10+
' каждая вершина, кроме корня, имеет от T до 2T детей. Вершину, имеющую '#13#10+
' ровно 2T детей, назовем полной (full).'#13#10+
#13#10+
' В простейшем случае T=2, тогда у каждой внутренней вершины 2, 3 '#13#10+
' ребенка, и мы получаем так называемое 2-3-дерево (2-3-4 tree).'#13#10;
//--------------
//типы
type
TTree=^TTreeElem;
TTreeList=record
key:integer;
kid:TTree;
end;
TTreeElem=record
count:integer;
isLeave:boolean;
keys:array of TTreeList;
end;
//----------------------
//глобальные переменные
var Degree:integer=2; //минимальная степень Б-дерева по-умолчанию
Root:TTree=nil; //корень
//---------------------------------------------------------------------------
//------------------------------блок подпрограмм-----------------------------
procedure writex(x:string); //вывод русской строки
var z:string;
begin
setlength(z,length(x));
CharToOem(PChar(x),PChar(z));
write(z);
end;
procedure writelnx(x:string); //вывод русской строки и переход на новую
var z:string;
begin
setlength(z,length(x));
CharToOem(PChar(x),PChar(z));
writeln(z);
end;
function Search(x:integer; Tree:TTree; var index:integer):TTree;
var i:integer; //поиск в дереве
F:boolean;
begin
result:=nil;
F:=false;
i:=Tree^.Count-1;
while (x<Tree^.keys[i].Key) and (not F) do
begin
if Tree^.keys[i].Kid<>nil then
if ((i>0) and (x>Tree^.keys[i-1].Key)) or (i=0) then //рекурсивный заход
result:=Search(x,Tree^.keys[i].Kid,index); //только при необходимости
if (result<>nil) then
F:=true
else i:=i-1;
end;
if not F then
begin
if i>-1 then
if x=Tree^.keys[i].Key then begin result:=Tree; index:=i; end;
end;
end;
function InsertKey(x:integer;T:TTree):TTree;forward;
//вставка поддерева в дерево (при удалении)
procedure InsertTree(Tree:TTree; var ToTree: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
ToTree:=InsertKey(Tree^.keys[i].Key,ToTree);
end;
if Tree^.keys[i].Kid<>nil then InsertTree(Tree^.keys[i].Kid,ToTree);
i:=i-1;
end;
end;
end;
function TerminateTree(Tree:TTree):TTree; //уничтожение дерева
var i:integer;
begin
result:=nil;
if Tree<>nil then
begin
i:=Tree^.Count-1;
while(i>=0)do
begin
if Tree^.keys[i].kid<>nil then Tree^.keys[i].kid:=TerminateTree(Tree^.keys[i].kid);
i:=i-1;
end;
Setlength(Tree^.keys,0);
FreeMem(Tree,sizeof(TTreeElem));
Tree:=nil;
result:=Tree;
end;
end;
function Parent(Rt,T:TTree;var ind:integer):TTree;forward; //опережающее
//определение
//поиска родителя
function DeleteFromTree(x:integer;Tree:TTree;var R:boolean):TTree;
var i,j:integer; //удаление элемента, R -флаг реорганизации дерева
ST:TTree; //если удален элемент полностью - это
begin //приводит к нарушению уровневой структуры, нужна
result:=Tree; //перестройка всего дерева
R:=false;
if Tree<>nil then
begin
i:=Tree^.Count-1; //рекурсивно ищем элемент
while(i>=0)and(Tree<>nil)do
begin
if Tree^.keys[i].kid<>nil then
Tree^.keys[i].kid:=DeleteFromTree(x,Tree^.keys[i].kid,R);
if x=Tree^.keys[i].Key then
BEGIN //нашли удаляемый
if Tree^.isLeave then //это лист
begin
if Tree^.Count>1 then //есть много элементов
begin
for j:=i to Tree^.Count-2 do //сжимаем
Tree^.keys[j]:=Tree^.keys[j+1];
Tree^.Count:=Tree^.Count-1;
SetLength(Tree^.keys,Tree^.Count);
end
else //это лист и в нем мы удаляем последний - реорганизация
begin
Tree^.keys[i].key:=MAX;
R:=true;
end;
end
else
if Tree^.Count>2 then //это не лист, но в нем есть много элементов
begin
ST:=Tree^.keys[i].Kid; //массив имеет более 1 элемента
for j:=i to Tree^.Count-2 do //сжимаем
Tree^.keys[j]:=Tree^.keys[j+1];
Tree^.Count:=Tree^.Count-1;
SetLength(Tree^.keys,Tree^.Count);
if ST<>nil then //есть потомок и если текущий (на месте удаленного)
begin //не имеет потомков - прицепляем, иначе - перестраиваем текущую вершину -->
if Tree^.keys[i].kid=nil then Tree^.keys[i].kid:=ST
else
InsertTree(ST,Tree) // --> добавлением в нее всех потомков удаленного
end;
end
else //удаляем элемент полностью - реорганизация
begin
Tree^.keys[i].key:=MAX;
R:=True;
end;
i:=0;
result:=Tree;
END;
i:=i-1;
end;
end;
end;
function Parent(Rt,T:TTree;var ind:integer):TTree; //поиск родителя
var i:integer;
begin
i:=0;
result:=nil;
while (Rt^.keys[i].kid<>T) and (i<Rt^.count) and (Rt<>T) do
begin
if Rt^.keys[i].kid<>nil then result:=Parent(Rt^.keys[i].kid,T,ind);
if result<>nil then break;
inc(i);
end;
if i<Rt^.count then
if (Rt^.keys[i].kid=T) then begin result:=Rt;ind:=i;end;
end;
function Split(T:TTree):TTree; //разделение вершины (рекурсивное)
var T1,T2,T3:TTree;
var i,j,m,d,k:integer;
begin
new(T2);
T2^.count:=Degree-1;
SetLength(T2^.keys,T2^.count);
T2^.isLeave:=true;
for i:=0 to Degree-2 do
begin
T2^.keys[i]:=T^.keys[i];
if T^.keys[i].kid<>nil then T2^.isLeave:=false;
end;
new(T3);
T3^.count:=T^.count-Degree;
SetLength(T3^.keys,T3^.count);
T3^.isLeave:=true;
for i:=Degree to T^.count-1 do
begin
T3^.keys[i-Degree]:=T^.keys[i];
if T^.keys[i].kid<>nil then T3^.isLeave:=false;
end;
m:=Degree-1;
if T^.keys[m].kid<>nil then
begin
T2^.count:=T2^.count+1;
SetLength(T2^.keys,T2^.count);
T2^.keys[T2^.count-1].kid:=T^.keys[m].kid;
T2^.keys[T2^.count-1].key:=MAX;
end;
j:=T^.keys[m].key;
T1:=Parent(Root,T,i);
if T1<>nil then
begin
if T1^.keys[T1^.count-1].key=MAX then D:=2*Degree else
D:=2*Degree-2;
if T1^.count>=D then
T1:=Split(T1)
else
begin
i:=0;
while (j>T1^.keys[i].key)and(i<T1^.count) do inc(i);
if i<=T1^.count then //insert to middle or start
begin
T1^.Count:=T1^.count+1;
SetLength(T1^.keys,T1^.count);
for k:=T1^.count-1 downto i+1 do
T1^.keys[k]:=T1^.keys[k-1];
T1^.keys[i].key:=j;
T1^.keys[i].kid:=T2;
T1^.keys[i+1].kid:=T3;
T1^.isLeave:=false;
end
end
end
else
begin
SetLength(T^.keys,2);
T^.count:=2;
T^.isLeave:=false;
T^.keys[0].key:=j;
T^.keys[0].kid:=T2;
T^.keys[1].kid:=T3;
T^.keys[1].key:=MAX;
end;
result:=T;
end;