Clase RBTree para Delphi usando genéricos
<Delphi <Indice
¿Qué es un árbol RB? (Wikipedia)
Reb-black tree
Un red-black tree (árbol rojo-negro) es un árbol binario de búsqueda equilibrado, que sirve tanto para implementar arrays asociativos como para recorrerlo de forma ordenada. Es complejo, pero tiene un buen peor caso de tiempo de ejecución para sus operaciones y es eficiente en la práctica. Puede buscar, insertar y borrar en un tiempo O(log n), donde n es el número de elementos del árbol.
Esta versión es una adaptación para Delphi 2009 y posteriores usando genéricos.
La conversión original (sin genéricos) a Delphi/ Free Pascal partiendo de la STL del gcc es obra de Freek van Walderveen, y la primera adaptación a genéricos para Free Pascal lo es de Jani Matyas.
Ambas versiones pueden encontrarse en la web de Freek van Walderveen.
Descargas
Licencia
This library is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See http://www.gnu.org/copyleft/gpl.html
This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
As a special exception, you may use this library as part of a free software library without restriction. Specifically, if you compile this library and link it with other files to produce an executable, this file does not by itself cause the resulting executable to be covered by the GNU General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU General Public License.
Código fuente
unit LibRBTree;
{
Red-black tree class, based on the STL tree implementation of
gcc-3.4.4 (/libstdc++-v3/include/bits/stl_tree.h and
/libstdc++-v3/src/tree.cc) of which the insertion and deletion
algorithms are based on those in Cormen, Leiserson and Rivest,
Introduction to Algorithms (MIT Press, 1990).
This unit should work ok with Embarcadero Delphi 2009+.
USAGE
The TRBTree class behaves somewhat like a TList: it stores pointers
and uses the same comparison function as TList.Sort (TListSortCompare).
Functions Clear, Add, Delete, First and Last are equivalent,
except that First and Last return a TRBNodeP instead of its key so they
can be used for comparisons in loops. All values occur only once in the
tree: when the same value is added twice, the second one is not stored.
To be able to manage the tree, the Create constructor has a argument
specifying the comparison function that should be used.
The function Find can be used to find a value that was put in the tree,
it searches for the given pointer using the comparison function given
at time of object creation. It returns a TRBNodeP.
The functions RBInc and RBDec can be used to "walk" through the tree:
given a TRBNodeP x, RBInc returns the TRBNodeP with the smallest key that
is larger than x, RBDec returns the TRBNodeP with the largest key that is
smaller than x. RBInc(tree.Last) and RBDec(tree.First) are not defined.
EXAMPLE
An example for usage of this unit can be found at
http://www.vanwal.nl/rbtree/example_grbtree.pas
COMPLEXITY
Create, First and Last are done in constant time.
Find, Add, Delete, RBInc and RBDec take O(log n) time, where n is the
number of items in the tree.
Destroy and Clear take O(n) time.
AUTHOR
Written (or "translated" ;-)) by Freek van Walderveen, november 2005
Generics version (Free Pascal) by Jani Matyas (jzombi)
Delphi 2009+ generics version by JRL
LICENCE
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
See http://www.gnu.org/copyleft/gpl.html
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
As a special exception, you may use this file as part of a free software
library without restriction. Specifically, if you compile
this file and link it with other files to produce an executable, this
file does not by itself cause the resulting executable to be covered by
the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
}
interface
uses
Types, SysUtils, Generics.Defaults, Generics.Collections;
type
{ JRL: if type TRBNodeColor is declared inside TRBTree<T>, compiler (Delphi 2010, XE, XE2, XE2+UP3)
fails with message "F2084 Internal Error: AV09C43E03-R0000000C-0".
}
TRBNodeColor = (rbRedNode, rbBlackNode);
TRBTree<T> = class
public
type
TRBNode = class
Value: T;
left, right, parent: TRBNode;
NodeColor: TRBNodeColor;
end;
private
root: TRBNode;
leftmost: TRBNode;
rightmost: TRBNode;
FComparer: IComparer<T>;
FOnNotify: TCollectionNotifyEvent<T>;
FCount: integer;
procedure RotateLeft(var x: TRBNode);
procedure RotateRight(var x: TRBNode);
function Minimum(var x: TRBNode): TRBNode;
function Maximum(var x: TRBNode): TRBNode;
procedure DoDelete(z: TRBNode; Notification: TCollectionNotification);
procedure fast_erase(x: TRBNode);
class procedure RBInc(var x: TRBNode);
class procedure RBDec(var x: TRBNode);
protected
procedure Notify(const Item: T; Action: TCollectionNotification); virtual;
public
constructor Create; overload;
constructor Create(AComparer: IComparer<T>); overload;
destructor Destroy; override;
procedure Clear;
function Find(const key: T): TRBNode;
function Add(const key: T; out alreadyExisted: boolean): TRBNode; overload;
function Add(const key: T): TRBNode; overload;
procedure Delete(z: TRBNode);
function Extract(z: TRBNode): T; overload;
function Extract(const Value: T): T; overload;
property First: TRBNode read leftmost;
property Last: TRBNode read rightmost;
function Next(x: TRBNode): TRBNode;
function Prior(x: TRBNode): TRBNode;
property Count: integer read FCount;
property OnNotify: TCollectionNotifyEvent<T> read FOnNotify write FOnNotify;
end; { class TRBTree }
TObjectRBTree<T: class> = class(TRBTree<T>)
protected
FOwnsObjects: Boolean;
procedure Notify(const Value: T; Action: TCollectionNotification); override;
public
constructor Create(AOwnsObjects: Boolean = True); overload;
constructor Create(const AComparer: IComparer<T>; AOwnsObjects: Boolean = True); overload;
property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;
end;
implementation
constructor TRBTree<T>.Create;
begin
Create(TComparer<T>.Default);
end;
constructor TRBTree<T>.Create(AComparer: IComparer<T>);
begin
inherited Create;
FComparer := AComparer;
root := nil;
leftmost := nil;
rightmost := nil;
end;
destructor TRBTree<T>.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TRBTree<T>.Notify(const Item: T; Action: TCollectionNotification);
begin
if Assigned(FOnNotify) then
FOnNotify(Self, Item, Action);
end;
procedure TRBTree<T>.fast_erase(x: TRBNode);
var
item: T;
begin
if (x.left <> nil) then fast_erase(x.left);
if (x.right <> nil) then fast_erase(x.right);
FCount := 0;
item := x.Value;
x.Free;
Notify(item, cnRemoved);
end;
procedure TRBTree<T>.Clear;
begin
if (root <> nil) then
fast_erase(root);
root := nil;
leftmost := nil;
rightmost := nil;
end;
function TRBTree<T>.Find(const key: T): TRBNode;
var
cmp: integer;
begin
Result := root;
while (Result <> nil) do begin
cmp := FComparer.Compare(Result.Value, key);
if cmp < 0 then begin
Result := Result.right;
end else if cmp > 0 then begin
Result := Result.left;
end else begin
break;
end;
end;
end;
procedure TRBTree<T>.RotateLeft(var x: TRBNode);
var
y: TRBNode;
begin
y := x.right;
x.right := y.left;
if (y.left <> nil) then begin
y.left.parent := x;
end;
y.parent := x.parent;
if (x = root) then begin
root := y;
end else if (x = x.parent.left) then begin
x.parent.left := y;
end else begin
x.parent.right := y;
end;
y.left := x;
x.parent := y;
end;
procedure TRBTree<T>.RotateRight(var x: TRBNode);
var
y: TRBNode;
begin
y := x.left;
x.left := y.right;
if (y.right <> nil) then begin
y.right.parent := x;
end;
y.parent := x.parent;
if (x = root) then begin
root := y;
end else if (x = x.parent.right) then begin
x.parent.right := y;
end else begin
x.parent.left := y;
end;
y.right := x;
x.parent := y;
end;
function TRBTree<T>.Minimum(var x: TRBNode): TRBNode;
begin
Result := x;
while (Result.left <> nil) do
Result := Result.left;
end;
function TRBTree<T>.Maximum(var x: TRBNode): TRBNode;
begin
Result := x;
while (Result.right <> nil) do
Result := Result.right;
end;
function TRBTree<T>.Add(const key: T): TRBNode;
var
alreadyExisted: boolean;
begin
Result := Add(key, alreadyExisted);
end;
function TRBTree<T>.Add(const key: T; out alreadyExisted: boolean): TRBNode;
var
x, y, z, zpp: TRBNode;
cmp: Integer;
begin
z := TRBNode.Create;
{ Initialize fields in new node z }
z.Value := key;
z.left := nil;
z.right := nil;
z.NodeColor := rbRedNode;
Result := z;
{ Maintain leftmost and rightmost nodes }
if ((leftmost = nil) or (FComparer.Compare(key, leftmost.Value) < 0)) then begin
leftmost := z;
end;
if ((rightmost = nil) or (FComparer.Compare(rightmost.Value, key) < 0)) then begin
rightmost := z;
end;
{ Insert node z }
y := nil;
x := root;
while (x <> nil) do begin
y := x;
cmp := FComparer.Compare(key, x.Value);
if (cmp < 0) then begin
x := x.left;
end else if (cmp > 0) then begin
x := x.right;
end else begin
{ Value already exists in tree. }
Result := x;
alreadyExisted := true;
z.Free; //a jzombi: memory leak: if we don't put it in the tree, we shouldn't hold it in the memory
exit;
end;
end;
z.parent := y;
if (y = nil) then begin
root := z;
end else if (FComparer.Compare(key, y.Value) < 0) then begin
y.left := z;
end else begin
y.right := z;
end;
{ Rebalance tree }
while ((z <> root) and (z.parent.NodeColor = rbRedNode)) do begin
zpp := z.parent.parent;
if (z.parent = zpp.left) then begin
y := zpp.right;
if ((y <> nil) and (y.NodeColor = rbRedNode)) then begin
z.parent.NodeColor := rbBlackNode;
y.NodeColor := rbBlackNode;
zpp.NodeColor := rbRedNode;
z := zpp;
end else begin
if (z = z.parent.right) then begin
z := z.parent;
rotateLeft(z);
end;
z.parent.NodeColor := rbBlackNode;
zpp.NodeColor := rbRedNode;
rotateRight(zpp);
end;
end else begin
y := zpp.left;
if ((y <> nil) and (y.NodeColor = rbRedNode)) then begin
z.parent.NodeColor := rbBlackNode;
y.NodeColor := rbBlackNode;
zpp.NodeColor := rbRedNode; //c jzombi: zpp.NodeColor := rbRedNode;
z := zpp;
end else begin
if (z = z.parent.left) then begin
z := z.parent;
rotateRight(z);
end;
z.parent.NodeColor := rbBlackNode;
zpp.NodeColor := rbRedNode; //c jzombi: zpp.NodeColor := rbRedNode;
rotateLeft(zpp);
end;
end;
end;
root.NodeColor := rbBlackNode;
alreadyExisted := false;
Inc(FCount);
Notify(key, cnAdded);
end;
procedure TRBTree<T>.DoDelete(z: TRBNode; Notification: TCollectionNotification);
var
w, x, y, x_parent: TRBNode;
tmpcol: TRBNodeColor;
item: T;
begin
y := z;
x := nil;
x_parent := nil;
if (y.left = nil) then begin { z has at most one non-null child. y = z. }
x := y.right; { x might be null. }
end else begin
if (y.right = nil) then begin { z has exactly one non-null child. y = z. }
x := y.left; { x is not null. }
end else begin
{ z has two non-null children. Set y to }
y := y.right; { z's successor. x might be null. }
while (y.left <> nil) do begin
y := y.left;
end;
x := y.right;
end;
end;
if (y <> z) then begin
{ "copy y's sattelite data into z" }
{ relink y in place of z. y is z's successor }
z.left.parent := y;
y.left := z.left;
if (y <> z.right) then begin
x_parent := y.parent;
if (x <> nil) then begin
x.parent := y.parent;
end;
y.parent.left := x; { y must be a child of left }
y.right := z.right;
z.right.parent := y;
end else begin
x_parent := y;
end;
if (root = z) then begin
root := y;
end else if (z.parent.left = z) then begin
z.parent.left := y;
end else begin
z.parent.right := y;
end;
y.parent := z.parent;
tmpcol := y.NodeColor;
y.NodeColor := z.NodeColor;
z.NodeColor := tmpcol;
y := z;
{ y now points to node to be actually deleted }
end else begin { y = z }
x_parent := y.parent;
if (x <> nil) then begin
x.parent := y.parent;
end;
if (root = z) then begin
root := x;
end else begin
if (z.parent.left = z) then begin
z.parent.left := x;
end else begin
z.parent.right := x;
end;
end;
if (leftmost = z) then begin
if (z.right = nil) then begin { z.left must be null also }
leftmost := z.parent;
end else begin
leftmost := minimum(x);
end;
end;
if (rightmost = z) then begin
if (z.left = nil) then begin { z.right must be null also }
rightmost := z.parent;
end else begin { x == z.left }
rightmost := maximum(x);
end;
end;
end;
{ Rebalance tree }
if (y.NodeColor = rbBlackNode) then begin
while ((x <> root) and ((x = nil) or (x.NodeColor = rbBlackNode))) do begin
if (x = x_parent.left) then begin
w := x_parent.right;
if (w.NodeColor = rbRedNode) then begin
w.NodeColor := rbBlackNode;
x_parent.NodeColor := rbRedNode;
rotateLeft(x_parent);
w := x_parent.right;
end;
if (((w.left = nil) or
(w.left.NodeColor = rbBlackNode)) and
((w.right = nil) or
(w.right.NodeColor = rbBlackNode))) then begin
w.NodeColor := rbRedNode;
x := x_parent;
x_parent := x_parent.parent;
end else begin
if ((w.right = nil) or (w.right.NodeColor = rbBlackNode)) then begin
w.left.NodeColor := rbBlackNode;
w.NodeColor := rbRedNode;
rotateRight(w);
w := x_parent.right;
end;
w.NodeColor := x_parent.NodeColor;
x_parent.NodeColor := rbBlackNode;
if (w.right <> nil) then begin
w.right.NodeColor := rbBlackNode;
end;
rotateLeft(x_parent);
x := root; { break; }
end
end else begin
{ same as above, with right <. left. }
w := x_parent.left;
if (w.NodeColor = rbRedNode) then begin
w.NodeColor := rbBlackNode;
x_parent.NodeColor := rbRedNode;
rotateRight(x_parent);
w := x_parent.left;
end;
if (((w.right = nil) or
(w.right.NodeColor = rbBlackNode)) and
((w.left = nil) or
(w.left.NodeColor = rbBlackNode))) then begin
w.NodeColor := rbRedNode;
x := x_parent;
x_parent := x_parent.parent;
end else begin
if ((w.left = nil) or (w.left.NodeColor = rbBlackNode)) then begin
w.right.NodeColor := rbBlackNode;
w.NodeColor := rbRedNode;
rotateLeft(w);
w := x_parent.left;
end;
w.NodeColor := x_parent.NodeColor;
x_parent.NodeColor := rbBlackNode;
if (w.left <> nil) then begin
w.left.NodeColor := rbBlackNode;
end;
rotateRight(x_parent);
x := root; { break; }
end;
end;
end;
if (x <> nil) then begin
x.NodeColor := rbBlackNode;
end;
end;
Dec(FCount);
item := y.Value;
y.Free;
Notify(item, Notification);
end;
procedure TRBTree<T>.Delete(z: TRBNode);
begin
DoDelete(z, cnRemoved);
end;
function TRBTree<T>.Extract(z: TRBNode): T;
begin
Result := z.Value;
DoDelete(z, cnExtracted);
end;
function TRBTree<T>.Extract(const Value: T): T;
var
z: TRBNode;
begin
z := Find(Value);
if z = nil then
Result := Default(T)
else begin
Result := z.Value;
DoDelete(z, cnExtracted);
end;
end;
function TRBTree<T>.Next(x: TRBNode): TRBNode;
begin
if x=rightmost then // made possible to do: node := tree.First; while node<>nil do node := tree.Next(node);
Result := nil
else begin
Result := x;
RBInc(Result);
end;
end;
function TRBTree<T>.Prior(x: TRBNode): TRBNode;
begin
if x=leftmost then // made possible to do: node := tree.Last; while node<>nil do node := tree.Prior(node);
Result := nil
else begin
Result := x;
RBDec(Result);
end;
end;
{ Pre: x <> last }
class procedure TRBTree<T>.RBInc(var x: TRBNode);
var
y: TRBNode;
begin
if (x.right <> nil) then begin
x := x.right;
while (x.left <> nil) do begin
x := x.left;
end;
end else begin
y := x.parent;
while (x = y.right) do begin
x := y;
y := y.parent;
end;
if (x.right <> y) then
x := y;
end
end;
{ Pre: x <> first }
class procedure TRBTree<T>.RBDec(var x: TRBNode);
var
y: TRBNode;
begin
if (x.left <> nil) then begin
y := x.left;
while (y.right <> nil) do begin
y := y.right;
end;
x := y;
end else begin
y := x.parent;
while (x = y.left) do begin
x := y;
y := y.parent;
end;
x := y;
end
end;
{ TObjectRBTree<T> }
constructor TObjectRBTree<T>.Create(AOwnsObjects: Boolean);
begin
inherited Create;
FOwnsObjects := AOwnsObjects;
end;
constructor TObjectRBTree<T>.Create(const AComparer: IComparer<T>; AOwnsObjects: Boolean);
begin
inherited Create(AComparer);
FOwnsObjects := AOwnsObjects;
end;
procedure TObjectRBTree<T>.Notify(const Value: T; Action: TCollectionNotification);
begin
inherited;
if OwnsObjects and (Action = cnRemoved) then
Value.Free;
end;
end.
|