|
@@ -0,0 +1,781 @@
|
|
|
+//
|
|
|
+// The graphics engine GXScene https://github.com/glscene
|
|
|
+//
|
|
|
+unit GLScene.RedBlackTree;
|
|
|
+
|
|
|
+(*
|
|
|
+ USAGE
|
|
|
+ The TRedBlackTree generic class behaves somewhat like a TList:
|
|
|
+ it stores _Value_ by _Key_
|
|
|
+ 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 _Key_ so they
|
|
|
+ can be used for comparisons in loops.
|
|
|
+
|
|
|
+ All _Key_ occur only once in the tree if DuplicateKeys is False:
|
|
|
+ when the same value is added twice, the second one is not stored.
|
|
|
+
|
|
|
+ When DuplicateKeys is enabled the second comparison function is used
|
|
|
+ for sort _Value_ and it duplicates not allowed.
|
|
|
+
|
|
|
+ To be able to manage the tree, the Create constructor has an 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 _Key_ using the comparison function given
|
|
|
+ at time of object creation.
|
|
|
+
|
|
|
+ The functions NextKey and PrevKey can be used to "walk" through the tree:
|
|
|
+ given a _Key_, NextKey replace it with the smallest key that
|
|
|
+ is larger than _Key_, PrevKey returns the largest key that is
|
|
|
+ smaller than _Key_. For Last and First key result not returned.
|
|
|
+*)
|
|
|
+
|
|
|
+interface
|
|
|
+
|
|
|
+{$I GLScene.Defines.inc}
|
|
|
+
|
|
|
+uses
|
|
|
+ System.Classes;
|
|
|
+
|
|
|
+type
|
|
|
+
|
|
|
+ TRBColor = (clRed, clBlack);
|
|
|
+
|
|
|
+{$IFDEF GENERIC_PREFIX}
|
|
|
+generic
|
|
|
+{$ENDIF}
|
|
|
+
|
|
|
+GRedBlackTree<TKey, TValue> = class
|
|
|
+ public
|
|
|
+ type
|
|
|
+ TKeyCompareFunc = function(const Item1, Item2: TKey): Integer;
|
|
|
+ TValueCompareFunc = function(const Item1, Item2: TValue): Boolean;
|
|
|
+ TForEachProc = procedure(AKey: TKey; AValue: TValue; out AContinue: Boolean);
|
|
|
+ TRBNode = class Key: TKey;
|
|
|
+ Left, Right, Parent, Twin: TRBNode;
|
|
|
+ Color:
|
|
|
+ TRBColor;
|
|
|
+ Value:
|
|
|
+ TValue;
|
|
|
+ end;
|
|
|
+
|
|
|
+ var
|
|
|
+ FRoot: TRBNode;
|
|
|
+ FLeftmost: TRBNode;
|
|
|
+ FRightmost: TRBNode;
|
|
|
+ FLastFound: TRBNode;
|
|
|
+ FLastNode: TRBNode;
|
|
|
+ FCount: Integer;
|
|
|
+ FKeyCompareFunc: TKeyCompareFunc;
|
|
|
+ FDuplicateKeys: Boolean;
|
|
|
+ FValueCompareFunc: TValueCompareFunc;
|
|
|
+ FOnChange: TNotifyEvent;
|
|
|
+
|
|
|
+ function FindNode(const Key: TKey): TRBNode;
|
|
|
+ procedure RotateLeft(var x: TRBNode);
|
|
|
+ procedure RotateRight(var x: TRBNode);
|
|
|
+ function Minimum(var x: TRBNode): TRBNode;
|
|
|
+ function Maximum(var x: TRBNode): TRBNode;
|
|
|
+ function GetFirst: TKey;
|
|
|
+ function GetLast: TKey;
|
|
|
+ procedure SetDuplicateKeys(Value: Boolean);
|
|
|
+ class procedure FastErase(x: TRBNode);
|
|
|
+ public
|
|
|
+ constructor Create(KeyCompare: TKeyCompareFunc;
|
|
|
+ ValueCompare: TValueCompareFunc);
|
|
|
+ destructor Destroy; override;
|
|
|
+ procedure Clear;
|
|
|
+ // Find value by key.
|
|
|
+ function Find(const Key: TKey; out Value: TValue): Boolean;
|
|
|
+ function NextKey(var Key: TKey; out Value: TValue): Boolean;
|
|
|
+ function PrevKey(var Key: TKey; out Value: TValue): Boolean;
|
|
|
+ function NextDublicate(out Value: TValue): Boolean;
|
|
|
+ procedure Add(const Key: TKey; const Value: TValue);
|
|
|
+ procedure Delete(const Key: TKey);
|
|
|
+ procedure ForEach(AProc: TForEachProc);
|
|
|
+ property Count: Integer read FCount;
|
|
|
+ property First: TKey read GetFirst;
|
|
|
+ property Last: TKey read GetLast;
|
|
|
+ property DuplicateKeys: Boolean read FDuplicateKeys
|
|
|
+ write SetDuplicateKeys;
|
|
|
+ property OnChange: TNotifyEvent read FOnChange
|
|
|
+ write FOnChange;
|
|
|
+end;
|
|
|
+
|
|
|
+function CompareInteger(const Item1, Item2: Integer): Integer;
|
|
|
+
|
|
|
+implementation // -------------------------------------------------------------
|
|
|
+
|
|
|
+function CompareInteger(const Item1, Item2: Integer): Integer;
|
|
|
+begin
|
|
|
+ if Item1 < Item2 then
|
|
|
+ begin
|
|
|
+ Result := -1;
|
|
|
+ end
|
|
|
+ else if (Item1 = Item2) then
|
|
|
+ begin
|
|
|
+ Result := 0;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ Result := 1;
|
|
|
+ end
|
|
|
+end;
|
|
|
+
|
|
|
+constructor GRedBlackTree<TKey, TValue>.Create(KeyCompare: TKeyCompareFunc;
|
|
|
+ ValueCompare: TValueCompareFunc);
|
|
|
+begin
|
|
|
+ inherited Create;
|
|
|
+ Assert(Assigned(KeyCompare));
|
|
|
+ FKeyCompareFunc := KeyCompare;
|
|
|
+ FValueCompareFunc := ValueCompare;
|
|
|
+ FRoot := nil;
|
|
|
+ FLeftmost := nil;
|
|
|
+ FRightmost := nil;
|
|
|
+ FDuplicateKeys := Assigned(ValueCompare);
|
|
|
+end;
|
|
|
+
|
|
|
+destructor GRedBlackTree<TKey, TValue>.Destroy;
|
|
|
+begin
|
|
|
+ Clear;
|
|
|
+ inherited Destroy;
|
|
|
+end;
|
|
|
+
|
|
|
+class procedure GRedBlackTree<TKey, TValue>.FastErase(x: TRBNode);
|
|
|
+var
|
|
|
+ y: TRBNode;
|
|
|
+begin
|
|
|
+ if (x.Left <> nil) then
|
|
|
+ FastErase(x.Left);
|
|
|
+ if (x.Right <> nil) then
|
|
|
+ FastErase(x.Right);
|
|
|
+ repeat
|
|
|
+ y := x;
|
|
|
+ x := x.Twin;
|
|
|
+ y.Destroy;
|
|
|
+ until x = nil;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure GRedBlackTree<TKey, TValue>.Clear;
|
|
|
+begin
|
|
|
+ if (FRoot <> nil) then
|
|
|
+ FastErase(FRoot);
|
|
|
+ FRoot := nil;
|
|
|
+ FLeftmost := nil;
|
|
|
+ FRightmost := nil;
|
|
|
+ FCount := 0;
|
|
|
+ if Assigned(FOnChange) then
|
|
|
+ FOnChange(Self);
|
|
|
+end;
|
|
|
+
|
|
|
+function GRedBlackTree<TKey, TValue>.Find(const Key: TKey;
|
|
|
+ out Value: TValue): Boolean;
|
|
|
+begin
|
|
|
+ FLastFound := FindNode(Key);
|
|
|
+ Result := Assigned(FLastFound);
|
|
|
+ if Result then
|
|
|
+ Value := FLastFound.Value;
|
|
|
+end;
|
|
|
+
|
|
|
+function GRedBlackTree<TKey, TValue>.FindNode(const Key: TKey): TRBNode;
|
|
|
+var
|
|
|
+ cmp: Integer;
|
|
|
+begin
|
|
|
+ Result := FRoot;
|
|
|
+ while (Result <> nil) do
|
|
|
+ begin
|
|
|
+ cmp := FKeyCompareFunc(Result.Key, 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;
|
|
|
+
|
|
|
+function GRedBlackTree<TKey, TValue>.NextDublicate(out Value: TValue): Boolean;
|
|
|
+begin
|
|
|
+ if Assigned(FLastFound) then
|
|
|
+ begin
|
|
|
+ if Assigned(FLastFound.Twin) then
|
|
|
+ begin
|
|
|
+ FLastFound := FLastFound.Twin;
|
|
|
+ Value := FLastFound.Value;
|
|
|
+ exit(True);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ Result := False;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure GRedBlackTree<TKey, TValue>.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 = FRoot) then
|
|
|
+ begin
|
|
|
+ FRoot := 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 GRedBlackTree<TKey, TValue>.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 = FRoot) then
|
|
|
+ begin
|
|
|
+ FRoot := 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 GRedBlackTree<TKey, TValue>.Minimum(var x: TRBNode): TRBNode;
|
|
|
+begin
|
|
|
+ Result := x;
|
|
|
+ while (Result.Left <> nil) do
|
|
|
+ Result := Result.Left;
|
|
|
+end;
|
|
|
+
|
|
|
+function GRedBlackTree<TKey, TValue>.Maximum(var x: TRBNode): TRBNode;
|
|
|
+begin
|
|
|
+ Result := x;
|
|
|
+ while (Result.Right <> nil) do
|
|
|
+ Result := Result.Right;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure GRedBlackTree<TKey, TValue>.Add(const Key: TKey; const Value: TValue);
|
|
|
+var
|
|
|
+ x, y, z, zpp: TRBNode;
|
|
|
+ cmp: Integer;
|
|
|
+begin
|
|
|
+ z := TRBNode.Create;
|
|
|
+
|
|
|
+ { Initialize fields in new node z }
|
|
|
+ z.Key := Key;
|
|
|
+ z.Left := nil;
|
|
|
+ z.Right := nil;
|
|
|
+ z.Color := clRed;
|
|
|
+ z.Value := Value;
|
|
|
+ z.Twin := nil;
|
|
|
+
|
|
|
+ { Maintain FLeftmost and FRightmost nodes }
|
|
|
+ if ((FLeftmost = nil) or (FKeyCompareFunc(Key, FLeftmost.Key) < 0)) then
|
|
|
+ begin
|
|
|
+ FLeftmost := z;
|
|
|
+ end;
|
|
|
+ if ((FRightmost = nil) or (FKeyCompareFunc(FRightmost.Key, Key) < 0)) then
|
|
|
+ begin
|
|
|
+ FRightmost := z;
|
|
|
+ end;
|
|
|
+
|
|
|
+ { Insert node z }
|
|
|
+ y := nil;
|
|
|
+ x := FRoot;
|
|
|
+ while (x <> nil) do
|
|
|
+ begin
|
|
|
+ y := x;
|
|
|
+ cmp := FKeyCompareFunc(Key, x.Key);
|
|
|
+ if cmp < 0 then
|
|
|
+ x := x.Left
|
|
|
+ else if cmp > 0 then
|
|
|
+ x := x.Right
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ { Key already exists in tree. }
|
|
|
+ if FDuplicateKeys then
|
|
|
+ begin
|
|
|
+ { Check twins chain for value dublicate. }
|
|
|
+ repeat
|
|
|
+ if FValueCompareFunc(Value, x.Value) then
|
|
|
+ begin
|
|
|
+ y := nil;
|
|
|
+ break;
|
|
|
+ end;
|
|
|
+ y := x;
|
|
|
+ x := x.Twin;
|
|
|
+ until x = nil;
|
|
|
+ if Assigned(y) then
|
|
|
+ begin
|
|
|
+ { Add dublicate key to end of twins chain. }
|
|
|
+ y.Twin := z;
|
|
|
+ Inc(FCount);
|
|
|
+ if Assigned(FOnChange) then
|
|
|
+ FOnChange(Self);
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+ // Value already exists in tree.
|
|
|
+ end;
|
|
|
+ z.Destroy;
|
|
|
+ // 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
|
|
|
+ FRoot := z;
|
|
|
+ end
|
|
|
+ else if (FKeyCompareFunc(Key, y.Key) < 0) then
|
|
|
+ begin
|
|
|
+ y.Left := z;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ y.Right := z;
|
|
|
+ end;
|
|
|
+
|
|
|
+ { Rebalance tree }
|
|
|
+ while ((z <> FRoot) and (z.Parent.Color = clRed)) do
|
|
|
+ begin
|
|
|
+ zpp := z.Parent.Parent;
|
|
|
+ if (z.Parent = zpp.Left) then
|
|
|
+ begin
|
|
|
+ y := zpp.Right;
|
|
|
+ if ((y <> nil) and (y.Color = clRed)) then
|
|
|
+ begin
|
|
|
+ z.Parent.Color := clBlack;
|
|
|
+ y.Color := clBlack;
|
|
|
+ zpp.Color := clRed;
|
|
|
+ z := zpp;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ if (z = z.Parent.Right) then
|
|
|
+ begin
|
|
|
+ z := z.Parent;
|
|
|
+ RotateLeft(z);
|
|
|
+ end;
|
|
|
+ z.Parent.Color := clBlack;
|
|
|
+ zpp.Color := clRed;
|
|
|
+ RotateRight(zpp);
|
|
|
+ end;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ y := zpp.Left;
|
|
|
+ if ((y <> nil) and (y.Color = clRed)) then
|
|
|
+ begin
|
|
|
+ z.Parent.Color := clBlack;
|
|
|
+ y.Color := clBlack;
|
|
|
+ zpp.Color := clRed; // c jzombi: zpp.color := clRed;
|
|
|
+ z := zpp;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ if (z = z.Parent.Left) then
|
|
|
+ begin
|
|
|
+ z := z.Parent;
|
|
|
+ RotateRight(z);
|
|
|
+ end;
|
|
|
+ z.Parent.Color := clBlack;
|
|
|
+ zpp.Color := clRed; // c jzombi: zpp.color := clRed;
|
|
|
+ RotateLeft(zpp);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ FRoot.Color := clBlack;
|
|
|
+ Inc(FCount);
|
|
|
+ if Assigned(FOnChange) then
|
|
|
+ FOnChange(Self);
|
|
|
+end;
|
|
|
+
|
|
|
+procedure GRedBlackTree<TKey, TValue>.Delete(const Key: TKey);
|
|
|
+var
|
|
|
+ w, x, y, z, x_parent: TRBNode;
|
|
|
+ tmpcol: TRBColor;
|
|
|
+begin
|
|
|
+ z := FindNode(Key);
|
|
|
+ if z = nil then
|
|
|
+ exit;
|
|
|
+
|
|
|
+ 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 (FRoot = z) then
|
|
|
+ begin
|
|
|
+ FRoot := 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.Color;
|
|
|
+ y.Color := z.Color;
|
|
|
+ z.Color := 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 (FRoot = z) then
|
|
|
+ begin
|
|
|
+ FRoot := 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 (FLeftmost = z) then
|
|
|
+ begin
|
|
|
+ if (z.Right = nil) then
|
|
|
+ begin // z.left must be null also
|
|
|
+ FLeftmost := z.Parent;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ FLeftmost := Minimum(x);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ if (FRightmost = z) then
|
|
|
+ begin
|
|
|
+ if (z.Left = nil) then
|
|
|
+ begin // z.right must be null also
|
|
|
+ FRightmost := z.Parent;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin // x == z.left
|
|
|
+ FRightmost := Maximum(x);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ // Rebalance tree
|
|
|
+ if (y.Color = clBlack) then
|
|
|
+ begin
|
|
|
+ while ((x <> FRoot) and ((x = nil) or (x.Color = clBlack))) do
|
|
|
+ begin
|
|
|
+ if (x = x_parent.Left) then
|
|
|
+ begin
|
|
|
+ w := x_parent.Right;
|
|
|
+ if (w.Color = clRed) then
|
|
|
+ begin
|
|
|
+ w.Color := clBlack;
|
|
|
+ x_parent.Color := clRed;
|
|
|
+ RotateLeft(x_parent);
|
|
|
+ w := x_parent.Right;
|
|
|
+ end;
|
|
|
+ if (((w.Left = nil) or (w.Left.Color = clBlack)) and
|
|
|
+ ((w.Right = nil) or (w.Right.Color = clBlack))) then
|
|
|
+ begin
|
|
|
+ w.Color := clRed;
|
|
|
+ x := x_parent;
|
|
|
+ x_parent := x_parent.Parent;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ if ((w.Right = nil) or (w.Right.Color = clBlack)) then
|
|
|
+ begin
|
|
|
+ w.Left.Color := clBlack;
|
|
|
+ w.Color := clRed;
|
|
|
+ RotateRight(w);
|
|
|
+ w := x_parent.Right;
|
|
|
+ end;
|
|
|
+ w.Color := x_parent.Color;
|
|
|
+ x_parent.Color := clBlack;
|
|
|
+ if (w.Right <> nil) then
|
|
|
+ begin
|
|
|
+ w.Right.Color := clBlack;
|
|
|
+ end;
|
|
|
+ RotateLeft(x_parent);
|
|
|
+ x := FRoot; { break; }
|
|
|
+ end
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ { same as above, with right <. left. }
|
|
|
+ w := x_parent.Left;
|
|
|
+ if (w.Color = clRed) then
|
|
|
+ begin
|
|
|
+ w.Color := clBlack;
|
|
|
+ x_parent.Color := clRed;
|
|
|
+ RotateRight(x_parent);
|
|
|
+ w := x_parent.Left;
|
|
|
+ end;
|
|
|
+ if (((w.Right = nil) or (w.Right.Color = clBlack)) and
|
|
|
+ ((w.Left = nil) or (w.Left.Color = clBlack))) then
|
|
|
+ begin
|
|
|
+ w.Color := clRed;
|
|
|
+ x := x_parent;
|
|
|
+ x_parent := x_parent.Parent;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ if ((w.Left = nil) or (w.Left.Color = clBlack)) then
|
|
|
+ begin
|
|
|
+ w.Right.Color := clBlack;
|
|
|
+ w.Color := clRed;
|
|
|
+ RotateLeft(w);
|
|
|
+ w := x_parent.Left;
|
|
|
+ end;
|
|
|
+ w.Color := x_parent.Color;
|
|
|
+ x_parent.Color := clBlack;
|
|
|
+ if (w.Left <> nil) then
|
|
|
+ begin
|
|
|
+ w.Left.Color := clBlack;
|
|
|
+ end;
|
|
|
+ RotateRight(x_parent);
|
|
|
+ x := FRoot; // break;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ if (x <> nil) then
|
|
|
+ begin
|
|
|
+ x.Color := clBlack;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ while Assigned(y.Twin) do
|
|
|
+ begin
|
|
|
+ z := y;
|
|
|
+ y := y.Twin;
|
|
|
+ z.Destroy;
|
|
|
+ end;
|
|
|
+ y.Destroy;
|
|
|
+ Dec(FCount);
|
|
|
+ if Assigned(FOnChange) then
|
|
|
+ FOnChange(Self);
|
|
|
+end;
|
|
|
+
|
|
|
+function GRedBlackTree<TKey, TValue>.NextKey(var Key: TKey;
|
|
|
+ out Value: TValue): Boolean;
|
|
|
+var
|
|
|
+ x, y: TRBNode;
|
|
|
+begin
|
|
|
+ if Assigned(FLastNode) and (FKeyCompareFunc(FLastNode.Key, Key) = 0) then
|
|
|
+ x := FLastNode
|
|
|
+ else
|
|
|
+ x := FindNode(Key);
|
|
|
+ if x = nil then
|
|
|
+ exit;
|
|
|
+ if (x.Right <> nil) then
|
|
|
+ begin
|
|
|
+ x := x.Right;
|
|
|
+ while (x.Left <> nil) do
|
|
|
+ begin
|
|
|
+ x := x.Left;
|
|
|
+ end;
|
|
|
+ end
|
|
|
+ else if (x.Parent <> nil) then
|
|
|
+ begin
|
|
|
+ y := x.Parent;
|
|
|
+ while Assigned(y) and (x = y.Right) do
|
|
|
+ begin
|
|
|
+ x := y;
|
|
|
+ y := y.Parent;
|
|
|
+ end;
|
|
|
+ if (x.Right <> y) then
|
|
|
+ x := y;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ x := FRoot;
|
|
|
+ if x = nil then
|
|
|
+ exit(False);
|
|
|
+ Key := x.Key;
|
|
|
+ FLastNode := x;
|
|
|
+ Value := x.Value;
|
|
|
+ Result := True;
|
|
|
+end;
|
|
|
+
|
|
|
+function GRedBlackTree<TKey, TValue>.PrevKey(var Key: TKey;
|
|
|
+ out Value: TValue): Boolean;
|
|
|
+var
|
|
|
+ x, y: TRBNode;
|
|
|
+begin
|
|
|
+ if Assigned(FLastNode) and (FKeyCompareFunc(FLastNode.Key, Key) = 0) then
|
|
|
+ x := FLastNode
|
|
|
+ else
|
|
|
+ x := FindNode(Key);
|
|
|
+ if x = nil then
|
|
|
+ exit(False);
|
|
|
+ if (x.Left <> nil) then
|
|
|
+ begin
|
|
|
+ y := x.Left;
|
|
|
+ while (y.Right <> nil) do
|
|
|
+ begin
|
|
|
+ y := y.Right;
|
|
|
+ end;
|
|
|
+ x := y;
|
|
|
+ end
|
|
|
+ else if (x.Parent <> nil) then
|
|
|
+ begin
|
|
|
+ y := x.Parent;
|
|
|
+ while (x = y.Left) do
|
|
|
+ begin
|
|
|
+ x := y;
|
|
|
+ y := y.Parent;
|
|
|
+ end;
|
|
|
+ x := y;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ x := FRoot;
|
|
|
+ if x = nil then
|
|
|
+ exit(False);
|
|
|
+ Key := x.Key;
|
|
|
+ FLastNode := x;
|
|
|
+ Value := x.Value;
|
|
|
+ Result := True;
|
|
|
+end;
|
|
|
+
|
|
|
+function GRedBlackTree<TKey, TValue>.GetFirst: TKey;
|
|
|
+begin
|
|
|
+ Result := FLeftmost.Key;
|
|
|
+end;
|
|
|
+
|
|
|
+function GRedBlackTree<TKey, TValue>.GetLast: TKey;
|
|
|
+begin
|
|
|
+ Result := FRightmost.Key;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure GRedBlackTree<TKey, TValue>.ForEach(AProc: TForEachProc);
|
|
|
+var
|
|
|
+ x, y, z: TRBNode;
|
|
|
+ cont: Boolean;
|
|
|
+begin
|
|
|
+ if Assigned(FLeftmost) then
|
|
|
+ begin
|
|
|
+ x := FLeftmost;
|
|
|
+ repeat
|
|
|
+ z := x;
|
|
|
+ repeat
|
|
|
+ AProc(z.Key, z.Value, cont);
|
|
|
+ if not cont then
|
|
|
+ exit;
|
|
|
+ z := z.Twin;
|
|
|
+ until z = nil;
|
|
|
+ // Next node
|
|
|
+ if (x.Right <> nil) then
|
|
|
+ begin
|
|
|
+ x := x.Right;
|
|
|
+ while (x.Left <> nil) do
|
|
|
+ begin
|
|
|
+ x := x.Left;
|
|
|
+ end;
|
|
|
+ end
|
|
|
+ else if (x.Parent <> nil) then
|
|
|
+ begin
|
|
|
+ y := x.Parent;
|
|
|
+ while (x = y.Right) do
|
|
|
+ begin
|
|
|
+ x := y;
|
|
|
+ y := y.Parent;
|
|
|
+ end;
|
|
|
+ if (x.Right <> y) then
|
|
|
+ x := y;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ x := FRoot;
|
|
|
+ until x = FRightmost;
|
|
|
+ if cont and (FLeftmost <> FRightmost) then
|
|
|
+ AProc(FRightmost.Key, FRightmost.Value, cont);
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure GRedBlackTree<TKey, TValue>.SetDuplicateKeys(Value: Boolean);
|
|
|
+begin
|
|
|
+ if Value and Assigned(FValueCompareFunc) then
|
|
|
+ FDuplicateKeys := True
|
|
|
+ else
|
|
|
+ FDuplicateKeys := False;
|
|
|
+end;
|
|
|
+
|
|
|
+end.
|