Clase RBTree para Delphi usando genéricos[an error occurred while processing this directive]

¿Qué es un árbol RB? (Wikipedia)

Reb-black tree

Descargas

Licencia

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.