|
1. pascal
2. delphi
========================================================================
1. Turbo Pacal
##############
//
// Taken from Nicklaus Wirth :
// Algorithmen und Datenstrukturen ( in Pascal )
// Balanced Binary Trees p 250 ++
//
// for Turbo Pascal
// not usable as it is in Delphi !!
//
//
//
//
unit BTree;
interface
type
ref=^node;
node=record
key:integer; // the data associated with the node
left,right:ref;
bal:-1..1;
count:byte;
end;
implementation
procedure search(x:integer;var p:ref;var h:boolean); // insert
var p1,p2:ref; // h=false
begin
if p=nil then
begin // word not in tree, insert it
new(p); h:=true;
with p^ do
begin
key:=x; count:=1;
left:=nil; right:=nil; bal:=0;
end;
end
else
if (xp^.key) then
begin
search(x,p^.right,h);
if h then // right branch got bigger
case p^.bal of
-1:begin
p^.bal:=0; h:=false;
end;
0: p^.bal:=+1;
+1:begin // new balancing
p1:=p^.right;
if p1^.bal=+1 then
begin // single rr rotation
p^.right:=p1^.left; p1^.left:=p;
p^.bal:=0; 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;
end;
p^.bal:=0; h:=false;
end;
end; // case
end
else
begin
p^.count:=p^.count+1;
h:=false;
end;
end; //search
procedure delete(x:integer;var p:ref;var h:boolean);
var q:ref; //h=false;
procedure balance1(var p:ref;var h:boolean);
var p1,p2:ref; b1,b2:byte;
begin //h=true left branch got smaller
case p^.bal of
-1: p^.bal:=0;
0: begin
p^.bal:=+1;h:=false;
end;
+1: begin // new balance
p1:=p^.right;b1:=p1^.bal;
if b1>=0 then
begin // simple rr rotation
p^.right:=p1^.left; p1^.left:=p;
if b1=0 then
begin
p^.bal:=+1; p1^.bal:=-1; h:=false;
end
else
begin
p^.bal:=0; p1^.bal:=0;
end;
p:=p1;
end
else
begin // double rl rotation
p2:=p1^.left; b2:=p2^.bal;
p1^.left:=p2^.right; p2^.right:=p1;
p^.right:=p2^.left; p2^.left:=p;
if b2=+1 then p^.bal:=-1 else p^.bal:=0;
if b2=-1 then p1^.bal:=+1 else p1^.bal:=0;
p:=p2;p2^.bal:=0;
end;
end; { +1}
end; { case }
end; { bal1 }
procedure balance2(var p:ref;var h:boolean);
var p1,p2:ref;b1,b2:byte;
begin //h=true right branch got smaller
case p^.bal of
-1: p^.bal:=0;
0: begin
p^.bal:=-1;h:=false;
end;
+1: begin // new balance
p1:=p^.left;b1:=p1^.bal;
if b1<=0 then
begin // simple ll rotation
p^.left:=p1^.right; p1^.right:=p;
if b1=0 then
begin
p^.bal:=-1; p1^.bal:=+1; h:=false;
end
else
begin
p^.bal:=0; p1^.bal:=0;
end;
p:=p1;
end
else
begin // double lr rotation
p2:=p1^.right; b2:=p2^.bal;
p1^.right:=p2^.left; p2^.left:=p1;
p^.left:=p2^.right; p2^.right:=p;
if b2=-1 then p^.bal:=+1 else p^.bal:=0;
if b2=+1 then p1^.bal:=-1 else p1^.bal:=0;
p:=p2;p2^.bal:=0;
end;
end; { +1}
end; { case }
end; { bal2 }
procedure del(var r:ref;var h:boolean);
begin //h=false
if r^.right<>nil then
begin
del(r^.right,h);
if h then balance2(r,h);
end
else
begin
q^.key:=r^.key;
q^.count:=r^.count;
q:=r;
r:=r^.left;h:=true;
end;
end;
begin { main of delete }
if (p=nil) then
begin
writeln('key not in tree');h:=false;
end
else
if (xp^.key)then
begin
delete(x,p^.right,h);
if h then balance2(p,h);
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 balance1(p,h);
end;
dispose(q);
end;
end; { delete }
end.
Delphi
#############################
//
// 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.
|
