unit BTree;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, BTreeClass;

type
TForm1 = class(TForm)
Edit1: TEdit;
AddButton: TButton;
RemoveButton: TButton;
SearchButton: TButton;
Label1: TLabel;
Label2: TLabel;
Memo1: TMemo;
Edit2: TEdit;
procedure AddButtonClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Edit1Change(Sender: TObject);
procedure RemoveButtonClick(Sender: TObject);
procedure SearchButtonClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
Tree:TBTree;

implementation

{$R *.dfm}

procedure TForm1.AddButtonClick(Sender: TObject);
begin
Tree.Add(StrToInt(Edit1.Text){,Edit2.Text});
Memo1.Lines.Add(Edit1.Text);
Label2.Caption:=IntToStr(TBTreeNode.NumAllocated);
Edit1.Text:='';
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Clear;
Tree:=TBTree.Create;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Tree.Free;
end;
procedure TForm1.Edit1Change(Sender: TObject);
begin
AddButton.Enabled:=(Edit1.Text<>'');
RemoveButton.Enabled:=(AddButton.Enabled and Tree.NotEmty);
SearchButton.Enabled:=(AddButton.Enabled and Tree.NotEmty);
end;

procedure TForm1.RemoveButtonClick(Sender: TObject);
begin
Tree.Remove(StrToInt(Edit1.Text));
Label2.Caption:=IntToStr(TBTreeNode.NumAllocated);
Edit1.Text:='';
end;

procedure TForm1.SearchButtonClick(Sender: TObject);
begin
Tree.Search(StrToInt(Edit1.Text));
Edit1.Text:='';
end;

end.


unit BTreeClass;

interface

uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
const
ORDER = 2; //порядок дерева
KEYS = 2*ORDER; //max кол-во ключей соотв. порядку

type
{ TNode = record
Key:integer;
text:string[508];
end; }

TBTreeNode = class(TObject) //класс узла дерева
NumKeys:integer; //кол-во ключей в сегменте
Key: array [1..KEYS] of integer; //сегмент
Child: array [0..KEYS] of TBTreeNode; //ссылки на дочерние сегменты
constructor Create;
destructor Destroy;override;
class function NumAllocated:integer;
end;

TBTree = class(TObject)
private
Root:TBTreeNode;
public
destructor Destroy; override;
procedure Add(new_key:integer{; new_text:string});
procedure AddNode(var node:TBtreeNode; new_key:Integer; var 
up_node:TBtreeNode; var up_key:Integer; var 
split:Boolean{;new_text,up_text:string});
procedure AddWithRoom(node,new_child:TBtreeNode; 
spot,new_key:Integer{,new_text:string});
procedure SplitNode(node:TBtreeNode; spot:Integer; var up_key:Integer; 
var up_node:TBtreeNode);
procedure Remove(Value:integer);
procedure RemoveFromNode(node:TBTreeNode; value:integer; var 
too_small:Boolean);
procedure SwapNode(node:TBtreeNode; key_num:Integer; 
down_node:TBtreeNode; var too_small:Boolean);
procedure TooSmall(parent, child:TBtreeNode; child_num:Integer; var 
too_small:Boolean);
function NotEmty:Boolean;
procedure Search(value:integer);
procedure SearchFromNode(node:TBTreeNode; value:integer; var 
search:Boolean);
end;

implementation

uses BTree;

var
NodesAllocated:integer;

{ TBTree }

procedure TBTree.Add(new_key: integer{; new_text:string});
var up_node,old_root:TBTreeNode;
up_key:integer;
split:boolean;
begin
AddNode(Root,new_key,up_node,up_key,split{,new_text,up_text});
if Split
then
begin
old_root:=Root;
Root:=TBtreeNode.Create;
Root.Key[1]:=up_key;
// Root.Key[1].text:=up_text;
Root.Child[0]:=old_root;
Root.Child[1]:=up_node;
Root.NumKeys:=1;
end
end;

procedure TBTree.AddNode(var node: TBtreeNode; new_key: Integer;
var up_node: TBtreeNode; var up_key: Integer; var split: Boolean{; 
new_text:string});
var branch:integer;
begin
if (node=nil) //если узел пуст, присваиваем ключ
then
begin
up_node:=nil;
up_key:=new_key;
// up_text:=new_text;
split:=true; //теперь мы можем добавить узел
exit;
end;
for branch:=0 to node.NumKeys-1 do //смотрим по какой ветке нам идти
if (node.Key[branch+1]>new_key) then break;
AddNode(node.Child[branch],new_key,up_node,up_key,split); //идем далее 
по ветке
if split
then
begin
if (node.NumKeys<KEYS) //если сегмент не полон, хотя бы одна ячейка 
пуста
then
begin //добавляем
AddWithRoom(node,up_node,branch+1,up_key);
split:=False; //это чтобы не создавать корень
end
else //иначе разбиваем сегмент
SplitNode(node,branch+1,up_key,up_node);
end;
end;

procedure TBTree.AddWithRoom(node, new_child: TBtreeNode; 
spot,new_key: Integer);
var i:integer;
begin
node.NumKeys:=node.NumKeys+1; //добавляем ключ в сегмент
for i:=node.NumKeys downto spot+1 do //сдвигаем элементы сегмента
begin
node.Key[i]:=node.Key[i-1];
// node.Key[i].text:=node.Key[i-1].text;
node.Child[i]:=node.Child[i-1];
end;
node.Key[spot]:=new_key; //вставляем наш новый элемент
node.Child[spot]:=new_child;
end;
destructor TBTree.Destroy;
begin
Root.Free;
inherited;
end;

function TBTree.NotEmty: Boolean;
begin
Result:=(Root<>nil);
end;

procedure TBTree.Remove(Value: integer);
var old_root:TBTreeNode;
too_small:Boolean;
begin
RemoveFromNode(Root,value,too_small);
if Root.NumKeys<1 //если корень пуст - удалить уровень
then
begin
old_root:=Root;
Root:=Root.Child[0]; //спускаемся по ссылке к сегменту - это новый 
корень
old_root.Child[0]:=nil;
old_root.Free; //удаляем старый корень
end;
end;

procedure TBTree.RemoveFromNode(node: TBTreeNode; value: integer;
var too_small: Boolean);
var branch,i:integer;
child:TBTreeNode;
match:Boolean;
begin
if (node = nil) //узел пуст - такого ключа нет
then
begin
ShowMessage('Узла с таким ключом в базе нет');
too_small:=False;
exit;
end;
match:=False;
for branch:= 1 to node.NumKeys do //просматриваем сегмент, ищем 
ветку
begin
if (value<=node.Key[branch]) then
begin
match:=(value=node.Key[branch]); //нашли?
break;
end;
end;
child := node.Child[branch - 1]; //
if (match) then
begin
if (child = nil) then //элемент в этом узле
begin //удаляем его
node.NumKeys := node.NumKeys - 1;
too_small := (node.NumKeys < ORDER); //сегмент маленький?
for i := branch to node.NumKeys do
node.Key[i] := node.Key[i + 1];
node.Key[node.NumKeys + 1] := 0;
end else begin //это не лист, значит надо взять элемент слева из листа
SwapNode(node, branch, child, too_small);
if (too_small) then //если теперь лист оказался маленьким - слить 
сегменты
TooSmall(node, child, branch - 1, too_small);
end;
end else begin //рекурсивно ищем удаляемый ключ для ребенка
RemoveFromNode(child, value, too_small);
if (too_small) then //если сегмент меленький - перестроить его
TooSmall(node, child, branch - 1, too_small);
end;
end;

procedure TBTree.Search(value: integer);
var search:Boolean;
begin
SearchFromNode(Root,value,search);
{ if (fl<>False)
then ShowMessage('Узел с ключом '+Form1.Edit1.Text+' есть в базе'); }
end;

procedure TBTree.SearchFromNode(node: TBTreeNode; value: integer; var 
search:Boolean);
var branch,i:integer;
child:TBTreeNode;
match,fl:Boolean;
begin
if (node = nil) //узел пуст - такого ключа нет
then
begin
ShowMessage('Узла с таким ключом в базе нет');
search:=False;
exit;
end;
match:=False;
fl:=False;
for branch:= 1 to node.NumKeys do
begin
if (value<=node.Key[branch]) then
begin
match:=(value=node.Key[branch]);
break;
end;
end;
if (match) then
begin
ShowMessage('Узел с ключом '+Form1.Edit1.Text+' есть в базе');
fl:=true;
end;
child := node.Child[branch - 1]; //
if (match)
then
begin
if (child = nil) and (not fl)
then
begin
ShowMessage('Узел с ключом '+Form1.Edit1.Text+' есть в базе')
end;
end
else SearchFromNode(child, value, search);
end;

procedure TBTree.SplitNode(node: TBtreeNode; spot: Integer;
var up_key: Integer; var up_node: TBtreeNode);
var i,return_key: integer;
return_node,right_child0:TBTreeNode;
begin
return_node:=TBTreeNode.Create; //создаем новый сегмент
if (spot<=ORDER+1) //смотрим куда нам надо вставлять новый ключ
then //проверяем место вставки по отношению к середине сенмента
begin
if (spot=ORDER+1) //вставлять надо на место сегмента, где 
ключ=середина+1
then
begin //объявляем тогда новый узел - корнем
return_key:=up_key;
right_child0:=up_node;
end
else
begin //иначе нам необходимо добавление в начало старого сегмента
return_key:=node.Key[ORDER]; //сохраняем ключ последнего эл-та в 
первой половине сегмента
right_child0:=node.Child[ORDER]; //сохраняем ссылку
node.Key[ORDER]:=0; //обнуляем ключ
node.Child[ORDER]:=nil; //и сбрасываем ссылку
for i:=ORDER downto spot+1 do //вставляем нов.узел в сегмент
begin
node.Key[i]:=node.Key[i-1]; //переписываем
node.Child[i]:=node.Child[i-1];
end;
node.Key[spot]:=up_key;
node.Child[spot]:=up_node;
end;
for i:=1 to ORDER do
begin //заносим вторую половину старого сегмента в первую нового
return_node.Key[i]:=node.Key[i+ORDER];
return_node.Child[i]:=node.Child[i+ORDER];
node.Key[i+ORDER]:=0; //вторую половину старого сегмента обнуляем
node.Child[i+ORDER]:=nil; //и сбрасываем ссылки
end;
end
else //иначе наш новый ключ должен быть самым правым
begin
spot:=spot-ORDER-1; //ставим тогда ветвь для нового сегмента в начало
return_key:=node.Key[ORDER+1]; //сохраняем ключ и левуюот него 
ссылку
right_child0:=node.Child[ORDER+1];
node.Key[ORDER+1]:=0; //обнуляем ключ и скидываем ссылку
node.Child[ORDER+1]:=nil;
for i:=1 to spot-1 do
begin //если надо - переносим узлы второй половины дробимого 
сегмента
return_node.Key[i]:=node.Key[i+ORDER+1];
return_node.Child[i]:=node.Child[i+ORDER+1];
node.Key[i+ORDER+1]:=0; //обнуляем эти узлы
node.Child[i+ORDER+1]:=nil;
end;
return_node.Key[spot]:=up_key; //вставляем новый ключ
return_node.Child[spot]:=up_node; //и ссылку
for i:=spot+1 to ORDER do
begin //освобождаем вторую половину старого сегмента, переносим в 
новый
return_node.Key[i]:=node.Key[i+ORDER];
return_node.Child[i]:=node.Child[i+ORDER];
node.Key[i+ORDER]:=0;
node.Child[i+ORDER]:=nil;
end;
end;
node.NumKeys:=ORDER; //задаем для новых сегментов кол-во ключей
return_node.NumKeys:=ORDER;
return_node.Child[0]:=right_child0; //определяем ссылку нового 
сегмента, как ту что сохранена в буфере
up_node:=return_node;
up_key:=return_key;
end;

procedure TBTree.SwapNode(node: TBtreeNode; key_num: Integer;
down_node: TBtreeNode; var too_small: Boolean);
var rightmost_child:TBtreeNode;
num:integer;
begin
num := down_node.NumKeys; //проверяем самый правый элемент
rightmost_child := down_node.Child[num];
if (rightmost_child = nil)
then
begin //элемент найден, меняем
node.Key[key_num] := down_node.Key[num]; //ставим последний 
элемент на место удаляемого
down_node.Key[num] := 0; //сам элемент обнуляем
down_node.NumKeys := num - 1; //кол-во ключей стало меньше
too_small := (down_node.NumKeys < ORDER); //проверяем кол-во 
ключей
end
else
begin //иначе мы еще не в листе, продолжаем спускаться
SwapNode(node, key_num, rightmost_child, too_small);
if (too_small) then // если сегмент слишком маленький
TooSmall(down_node,rightmost_child,down_node.NumKeys,too_small);
end;
end;

procedure TBTree.TooSmall(parent,child:TBtreeNode; child_num:Integer; 
var too_small:Boolean);
var num_in_parent,num_in_sibling:integer;
num_to_move,i:integer;
sibling:TBtreeNode;
begin
num_in_parent := parent.NumKeys;
if (child_num < num_in_parent) //смотрим количество ключей у смежных 
сегментов
then
begin //проверяем смежный сегмент справа, хватит ли ему ключей
child_num := child_num + 1;
sibling := parent.Child[child_num];
num_in_sibling := sibling.NumKeys;
num_to_move := (num_in_sibling - ORDER + 1) div 2;
child.Key[ORDER] := parent.Key[child_num];
child.Child[ORDER] := sibling.Child[0];
sibling.Child[0] := nil;
if (num_to_move > 0) //ключей хватает?
then
begin
for i := 1 to num_to_move - 1 do
begin //тогда переносим
child.Key[i + ORDER] := sibling.Key[i];
child.Child[i + ORDER] := sibling.Child[i];
sibling.Key[i] := 0;
sibling.Child[i] := nil;
end;
parent.Key[child_num] := sibling.Key[num_to_move]; //определяем 
родителя
parent.Child[child_num] := sibling;
sibling.Child[0] := sibling.Child[num_to_move];//начинаем заполнять 
пустое место
num_in_sibling := num_in_sibling - num_to_move;
for i := 1 to num_in_sibling do
begin //переносим элементы в смежном сегменте
sibling.Key[i] := sibling.Key[i + num_to_move];
sibling.Child[i] := sibling.Child[i + num_to_move];
sibling.Key[i + num_to_move] := 0; //те что перенесли обнуляем
sibling.Child[i + num_to_move] := nil;
end;
sibling.NumKeys := num_in_sibling; //обновляем кол-во ключей в брате
child.NumKeys := ORDER - 1 + num_to_move; //в сегменте, где удаляли
too_small := False; //говорим что здесь уже все в порядке
end
else //иначе не хватает ключей для перерасперделения - необходимо 
слияние
begin
for i := 1 to ORDER do
begin //переносим из брата в сегмент, из которого удаляли
child.Key[i + ORDER] := sibling.Key[i];
child.Child[i + ORDER] := sibling.Child[i];
sibling.Key[i] := 0;
sibling.Child[i] := nil;
end;
for i := child_num to num_in_parent - 1 do
begin //аполняем пустое место в родителе
parent.Key[i] := parent.Key[i + 1];
parent.Child[i] := parent.Child[i + 1];
end;
parent.Key[num_in_parent] := 0; //обнуляемпоследний элемент
parent.Child[num_in_parent] := nil;
child.NumKeys := KEYS; //кол-во ключей обновляем
parent.NumKeys := num_in_parent - 1;
sibling.Free; //удаляем брата
too_small := (parent.NumKeys < ORDER); //проверяем кол-во ключей 
родителя
end;
end else begin //справа правильных смежных нет, проверяем левого
sibling := parent.Child[child_num - 1];
num_in_sibling := sibling.NumKeys + 1;
num_to_move := (num_in_sibling - ORDER) div 2;
if (num_to_move > 0) then
begin //подходит, освобождаем место в ребенке
for i := ORDER - 1 downto 1 do
begin //сдвигаем вправо
child.Key[i + num_to_move] := child.Key[i];
child.Child[i + num_to_move] := child.Child[i];
end; //забираем элемент из родителя, заполняем
child.Key[num_to_move] := parent.Key[child_num];
child.Child[num_to_move] := child.Child[0];
num_in_sibling := num_in_sibling - num_to_move; //смотрим сколько 
отдавать ребенку от смежного
for i := num_to_move - 1 downto 1 do
begin //переносим элементы
child.Key[i] := sibling.Key[i + num_in_sibling];
child.Child[i] := sibling.Child[i + num_in_sibling];
sibling.Key[i + num_in_sibling] := 0;
sibling.Child[i + num_in_sibling] := nil;
end;
child.Child[0] := sibling.Child[num_in_sibling]; //определяем ссылки на 
детей от ребенка
sibling.Child[num_in_sibling] := nil;
parent.Key[child_num] := sibling.Key[num_in_sibling]; //обновляем 
ссылку от родителя к смежному
sibling.NumKeys := num_in_sibling - 1; //кол-во ключей обновляем
child.NumKeys := ORDER - 1 + num_to_move;
too_small := False;
end else begin //если недостаточно ключей - сливаем
sibling.Key[num_in_sibling] := parent.Key[child_num]; //переносим 
элемент родителя к смежному
sibling.Child[num_in_sibling] := child.Child[0];
child.Child[0] := nil;
for i := 1 to ORDER - 1 do //перемещаем значения из ребенка в брата
begin
sibling.Key[i + num_in_sibling] := child.Key[i];
sibling.Child[i + num_in_sibling] := child.Child[i];
child.Key[i] := 0;
child.Child[i] := nil;
end;
sibling.NumKeys := KEYS; //обновляем кол-во ключей
parent.NumKeys := num_in_parent - 1;
parent.Key[child_num] := 0;
parent.Child[child_num] := nil;
child.NumKeys := 0;
child.Free; //удаляем пустой сегмент
too_small := (parent.NumKeys < ORDER); //проверяем кол-во ключей 
родителя
end;
end;
end;

{ TBTreeNode }

constructor TBTreeNode.Create;
begin //создание нового сегмента, кол-во узлов +1
inherited Create;
NodesAllocated:=NodesAllocated+1;
end;

destructor TBTreeNode.Destroy;
var
i:integer;
begin //удаление сегмента, кол-во сегментов -1
NodesAllocated:=NodesAllocated-1;
for i:=0 to NumKeys do //освобождение ссылок от ключей
Child[i].Free;
inherited;
end;
class function TBTreeNode.NumAllocated: integer;
begin //получение кол-ва сегментов
Result:=NodesAllocated;
end;

end.