where : ibrtses delphi
balanced binary trees
disclaimer
the source code of this page may not appear correctly in certain browsers
due to special characters. Have a look at the source of this HTML page
with notepad instead
balanced binary trees are very efficient structures for data when fast
searching is required. Searching an element in 65536 requires at most
16 (full) compares.
The following code was enhanced with capabilities to search-only and
list the tree, after Mr Giacomo Policicchio, found
some errors in the
previously listed code. He was also able to shorten it quite a bit.
I thank him for his valuable contributions.
Compare with balanced binary trees in Turbo Pascal
The unit
//
// Taken from Nicklaus Wirth :
// Algorithmen und Datenstrukturen ( in Pascal )
// Balanced Binary Trees p 250 ++
//
//
// Fixed By Giacomo Policicchio
// pgiacomo@tiscalinet.it
// 19/05/2000
//
unit BinaryTree;
interface
uses classes;
type
TBinTreeItem=
class(TObject)
left,right:TBinTreeItem;
bal:-1..1;
private
count:integer;
public
constructor create;
function compare(a:TBinTreeItem):Shortint; virtual; abstract; // data
// a < self :-1 a=self :0 a > self :+1
procedure copy(ToA:TBinTreeItem); virtual; abstract; // data
procedure list; virtual; abstract; // used to list the tree
end;
TBinTree=class(TPersistent)
root:TBinTreeItem;
private
ItemCount:integer;
procedure Delete(item:TBinTreeItem;var p:TBinTreeItem;var h:boolean;var ok:boolean);
procedure SearchAndInsert(item:TBinTreeItem;Var p:TBinTreeItem;var h:boolean;Var Found:boolean);
function SearchItem(item:TBinTreeItem;Var p:TBinTreeItem):boolean;
procedure balanceLeft(var p:TBinTreeItem;var h:boolean;dl:boolean);
procedure balanceRight(var p:TBinTreeItem;var h:boolean;dl:boolean);
procedure listitems(var p:TBinTreeItem);
public
constructor create;
destructor destroy;
Function add(item:TBinTreeItem):boolean;
Function remove(item:TBinTreeItem):boolean;
function search(item:TBinTreeItem):boolean;
procedure list; // uses item.list through listitems recursively
end;
implementation
//=================================================================
constructor TBinTreeItem.create;
begin
inherited create;
count:=0;
end;
//=================================================================
constructor TBinTree.create;
begin
inherited create;
root:=nil;
ItemCount:=0;
end;
destructor TBinTree.destroy;
begin
while root <> nil do remove(root);
inherited destroy;
end;
procedure TBinTree.SearchAndInsert(item:TBinTreeItem;Var p:TBinTreeItem;var h:boolean;Var Found:boolean);
begin
found:=false;
if p=nil then begin // word not in tree, insert it
p:=item;
h:=true;
with p do
begin
if root=nil then root:=p;
count:=1;
left:=nil; right:=nil; bal:=0;
end;
end
else
if (item.compare(p) > 0) then // new < current
begin
searchAndInsert(item,p.left,h,found);
if h and not found then BalanceLeft(p,h,false);
end
else
if (item.compare(p) < 0) then // new > current
begin
searchAndInsert(item,p.right,h,found);
if h and not found then balanceRight(p,h,false);
end
else
begin
p.count:=p.count+1;
h:=false;
found:=true;
end;
end; //searchAndInsert
// returns true and a pointer to the equal item if found, false otherwise
function TBinTree.SearchItem(item:TBinTreeItem;Var p:TBinTreeItem):boolean;
begin
result:=false;
if (p=nil) then result:=false // empty
else begin
if (item.compare(p) =0) then result:=true
else begin
if (item.compare(p) >0) then result:=searchitem(item,p.left)
else begin
if (item.compare(p) <0) then result:=searchitem(item,p.right)
end;
end;
end;
end;
procedure TBinTree.balanceRight(var p:TBinTreeItem;var h:boolean;Dl:boolean);
var p1,p2:TBinTreeItem;
Begin
case p.bal of
-1:begin
p.bal:=0;
if not dl then h:=false;
end;
0: begin
p.bal:=+1;
if dl then h:=false;
end;
+1:begin // new balancing
p1:=p.right;
if (p1.bal=+1) or ((p1.bal=0) and dl) then begin // single rr rotation
p.right:=p1.left; p1.left:=p;
if not dl then p.bal:=0
else begin
if p1.bal=0 then begin
p.bal:=+1; p1.bal:=-1; h:=false;
end
else begin
p.bal:=0; p1.bal:=0;
(* h:=false; *)
end;
end;
p:=p1;
end
else begin // double rl rotation
p2:=p1.left;
p1.left:=p2.right;
p2.right:=p1;
p.right:=p2.left;
p2.left:=p;
if p2.bal=+1 then p.bal:=-1 else p.bal:=0;
if p2.bal=-1 then p1.bal:=+1 else p1.bal:=0;
p:=p2;
if dl then p2.bal:=0;
end;
if not dl then begin
p.bal:=0;
h:=false;
end;
end;
end; // case
End;
procedure TBinTree.balanceLeft(var p:TBinTreeItem;var h:boolean;dl:boolean);
var p1,p2:TBinTreeItem;
Begin
case p.bal of
1:begin
p.bal:=0;
if not dl then h:=false;
end;
0:begin
p.bal:=-1;
if dl then h:=false;
end;
-1:(* if (p.Left<>nil) or not dl then *)
begin // new balancing
p1:=p.left;
if (p1.bal=-1) or ((p1.bal=0) and dl) then begin // single ll rotation
p.left:=p1.right;p1.right:=p;
if not dl then p.bal:=0
else begin
if p1.bal=0 then begin
p.bal:=-1;
p1.bal:=+1;
h:=false;
end
else begin
p.bal:=0;
p1.bal:=0;
(* h:=false; *)
end;
end;
p:=p1;
end
else
begin //double lr rotation
p2:=p1.right;
P1.Right:=p2.left;
p2.left:=p1;
p.left:=p2.right;
p2.right:=p;
if p2.bal=-1 then p.bal:=+1 else p.bal:=0;
if p2.bal=+1 then p1.bal:=-1 else p1.bal:=0;
p:=p2;if dl then p2.bal:=0;
end;
if not dl then begin
p.bal:=0;
h:=false;
end;
end; { -1 }
end; { case }
End;
procedure TBinTree.Delete(item:TBinTreeItem;var p:TBinTreeItem;var h:boolean;var ok:boolean);
var q:TBinTreeItem; //h=false;
procedure del(var r:TBinTreeItem;var h:boolean);
begin //h=false
if r.right <> nil then
begin
del(r.right,h);
if h then balanceLeft(r,h,True);
end
else
begin
r.copy(q); { q.key:=r.key; }
q.count:=r.count;
q:=r;
r:=r.left;h:=true;
end;
end;
begin { main of delete }
ok:=true;
if (p=nil) then
begin
Ok:=false;h:=false;
end
else
if (item.compare(p) > 0){(x < p^.key)} then
begin
delete(item,p.left,h,ok);
if h then balanceRight(p,h,True);
end
else
if (item.compare(p) < 0){(x > p^.key)}then
begin
delete(item,p.right,h,ok);
if h then balanceLeft(p,h,True);
end
else
begin // remove q
q:=p;
if q.right=nil then
begin
p:=q.left;h:=true;
end
else
if (q.left=nil) then
begin
p:=q.right;h:=true;
end
else
begin
del(q.left,h);
if h then balanceRight(p,h,True);
end;
q.free; {dispose(q)};
end;
end; { delete }
Function TBinTree.add(item:TBinTreeItem):boolean;
var h,found:boolean;
begin
SearchAndInsert(item,root,h,found);
add:=found;
end;
Function TBinTree.remove(item:TBinTreeItem):Boolean;
var h,ok:boolean;
begin
Delete(item,root,h,ok);
remove:=ok;
end;
Function TBinTree.Search(item:TBinTreeItem):Boolean;
var h,ok:boolean;
begin
result:=SearchItem(item,root);
end;
procedure TBinTree.listitems(var p:TBinTreeItem);
begin
if p<>nil then begin
if (p.left <> nil) then listitems(p.left);
p.list;
if (p.right <> nil) then listitems(p.right);
end;
end;
procedure TBinTree.list; // uses item.list recursively
begin
listitems(root);
end;
end.
A sample application
unit BTree1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
BinaryTree, StdCtrls, Spin;
type
TForm1 = class(TForm)
add: TButton;
SpinEdit1: TSpinEdit;
Memo1: TMemo;
list: TButton;
search: TButton;
searchresult: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure addClick(Sender: TObject);
procedure listClick(Sender: TObject);
procedure searchClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
bt:TBintree
end;
TmyTreeItem=class(TBinTreeItem) // the base class has to be overriden !
public
data:integer;
constructor create(i:integer);
function compare(a:TBinTreeItem):Shortint; override; // data
// a < self :-1 a=self :0 a > self :+1
procedure copy(ToA:TBinTreeItem); override; // data
procedure list; override;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
constructor TmyTreeItem.create(i:integer);
begin
inherited create;
data:=i;
end;
// a < self :-1 a=self :0 a > self :+1
function TmyTreeItem.compare(a:TBinTreeItem):Shortint;
begin
if TmyTreeItem(a).data < data then result:=-1
else
if TmyTreeItem(a).data = data then result:=0
else
if TmyTreeItem(a).data > data then result:=1;
end;
procedure TmyTreeItem.copy(ToA:TBinTreeItem);
begin
TmyTreeItem(ToA).data:=data;
end;
procedure TmyTreeItem.list;
begin
form1.memo1.lines.add(inttostr(data));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
bt:=TBinTree.create;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
bt.destroy;
end;
procedure TForm1.addClick(Sender: TObject);
var bti:TmyTreeItem;
h:boolean;
begin
bti:=TmyTreeItem.create( SpinEdit1.value);
h:=bt.add(bti);
end;
procedure TForm1.listClick(Sender: TObject);
begin
memo1.clear;
bt.list;
end;
procedure TForm1.searchClick(Sender: TObject);
var bti,j:TmyTreeItem;
begin
bti:=TmyTreeItem.create( SpinEdit1.value);
j:=bti;
if bt.Search(j) then searchresult.caption:='Y' else searchresult.caption:='N';
bti.destroy;
end;
end.
Feedback is welcome
sponsored links
Delphi
home
last updated: 19.may.00
Copyright (99,2000) Ing.Büro R.Tschaggelar