通过检查 Delphi 源代码的 Tomes 并与算法或 Julian 的其他实现（高度优化的 EZDSL 库实现）进行比较，我还没有设法找出问题所在（因此是这个问题！），但我改为重新实现Delete，并且为了更好的衡量标准Insert，基于Literate Programming 站点上的红黑树示例 C 代码，我发现的红黑树最清晰的例子之一。（实际上，纯粹通过打磨代码并验证它是否正确地实现了某些错误，实际上是一项相当艰巨的任务，尤其是当您不完全理解算法时。我可以告诉您，我现在理解得更好了！）树有很好的文档记录 - 我认为 Delphi 的 Tomes 更好地概述了树为何如此工作的原因，但此代码是可读实现的更好示例。
关于这一点的注意事项：
- 评论通常是从页面对特定方法的解释中直接引用的。
- 尽管我已经将过程式 C 代码移到了面向对象的结构中，但移植起来非常容易。有一些小怪癖，例如 Bucknall 的树有一个
FHead节点，其子节点是树的根，转换时必须注意这一点。（测试经常测试节点的父节点是否为 NULL 作为测试节点是否为根节点的一种方式。我已经将这个和其他类似的逻辑提取到辅助方法、节点或树方法。）
- 读者可能还会发现关于红黑树的永恒困惑页面很有用。虽然我在编写这个实现时没有使用它，但我可能应该使用它，如果这个实现中有错误，我会转向那里寻求洞察力。这也是我在调试ToD时研究RB树时发现的第一页，其中提到了红黑树和2-3-4树之间的联系。
- 如果不清楚，此代码修改了 Tomes of Delphi 示例
TtdBinaryTree，TtdBinarySearchTree可TtdRedBlackTree在TDBinTre.pas（ToD 页面上的源代码下载）中找到。要使用它，请编辑该文件。这不是一个新的实现，它本身并不完整。具体来说，它保留了 ToD 代码的结构，例如TtdBinarySearchTree不是TtdBinaryTree作为成员的后代但拥有一个成员（即包装它），使用FHead节点而不是 的 nil 父级Root等。
- 原始代码是 MIT 许可的。（该站点正在迁移到另一个许可证；当您检查它时它可能已经更改。对于未来的读者，在撰写本文时，代码肯定是在 MIT 许可证下。）我不确定 Tomes 的许可证德尔福代码；由于它在算法书中，因此假设您可以使用它可能是合理的 - 我认为它隐含在参考书中。就我而言，只要您遵守原始许可证，欢迎您使用它：）如果有用请发表评论，我想知道。
- Delphi 的实现通过使用祖先排序二叉树的插入方法进行插入，然后“提升”节点来工作。逻辑在这两个地方之一。这个实现也实现了插入，然后进入一些案例来检查位置并通过显式旋转来修改它。这些旋转在单独的方法（
RotateLeft和RotateRight）中，我觉得这很有用 - ToD 代码讨论了旋转，但没有明确地将它们拉入单独的命名方法中。 Delete是相似的：它涉及许多案例。每个案例都在页面上进行了解释，并在我的代码中作为注释。其中一些是我命名的，但有些太复杂而无法输入方法名称，因此只是“案例 4”、“案例 5”等，并附有注释说明。
- 该页面还包含验证树结构和红黑属性的代码。作为编写单元测试的一部分，我已经开始这样做，但还没有完全添加所有的红黑树约束，因此也将此代码添加到树中。它只存在于调试版本中，并在出现问题时进行断言，因此在调试中完成的单元测试会发现问题。
- 这棵树现在通过了我的单元测试，尽管它们可能更广泛——我编写它们是为了让调试 Tomes of Delphi 树更简单。此代码没有任何形式的保证或保证。认为它未经测试。在使用之前编写测试。如果您发现错误，请发表评论:)
上代码！
节点修改
我在节点中添加了以下辅助方法，以使代码在阅读时更具素养。例如，原始代码通常通过测试（盲转换到 Delphi 和未修改的 ToD 结构）来测试节点是否是其父节点的左子节点，if Node = Node.Parent.btChild[ctLeft] then...而现在您可以测试if Node.IsLeft then...等。记录定义中的方法原型不包括在内以保存空间，但应该很明显:)
function TtdBinTreeNode.Parent: PtdBinTreeNode;
begin
assert(btParent <> nil, 'Parent is nil');
Result := btParent;
end;
function TtdBinTreeNode.Grandparent: PtdBinTreeNode;
begin
assert(btParent <> nil, 'Parent is nil');
Result := btParent.btParent;
assert(Result <> nil, 'Grandparent is nil - child of root node?');
end;
function TtdBinTreeNode.Sibling: PtdBinTreeNode;
begin
assert(btParent <> nil, 'Parent is nil');
if @Self = btParent.btChild[ctLeft] then
Exit(btParent.btChild[ctRight])
else
Exit(btParent.btChild[ctLeft]);
end;
function TtdBinTreeNode.Uncle: PtdBinTreeNode;
begin
assert(btParent <> nil, 'Parent is nil');
// Can be nil if grandparent has only one child (children of root have no uncle)
Result := btParent.Sibling;
end;
function TtdBinTreeNode.LeftChild: PtdBinTreeNode;
begin
Result := btChild[ctLeft];
end;
function TtdBinTreeNode.RightChild: PtdBinTreeNode;
begin
Result := btChild[ctRight];
end;
function TtdBinTreeNode.IsLeft: Boolean;
begin
Result := @Self = Parent.LeftChild;
end;
function TtdBinTreeNode.IsRight: Boolean;
begin
Result := @Self = Parent.RightChild;
end;
我还添加了额外的方法，例如现有的，以测试它是否为黑色（如果不是， IsRed()IMO 代码会更好地扫描，并获取颜色，包括处理 nil 节点。请注意，这些需要保持一致 -例如，返回对于 nil 节点为 false，因此 nil 节点是黑色的。（这也与红黑树的属性以及通往叶子的路径上的一致数量的黑色节点有关。）if IsBlack(Node)if not IsRed(Node)IsRed
function IsBlack(aNode : PtdBinTreeNode) : boolean;
begin
Result := not IsRed(aNode);
end;
function NodeColor(aNode :PtdBinTreeNode) : TtdRBColor;
begin
if aNode = nil then Exit(rbBlack);
Result := aNode.btColor;
end;
红黑约束验证
如上所述，这些方法验证了树的结构和红黑约束，并且是原始 C 代码中相同方法的直接翻译。 Verify如果在类定义中没有调试，则声明为内联。如果不调试，该方法应该是空的，并有望被编译器完全删除。 在and方法Verify的开头和结尾调用，以确保树在修改前后是正确的。InsertDelete
procedure TtdRedBlackTree.Verify;
begin
{$ifdef DEBUG}
VerifyNodesRedOrBlack(FBinTree.Root);
VerifyRootIsBlack;
// 3 is implicit
VerifyRedBlackRelationship(FBinTree.Root);
VerifyBlackNodeCount(FBinTree.Root);
{$endif}
end;
procedure TtdRedBlackTree.VerifyNodesRedOrBlack(const Node : PtdBinTreeNode);
begin
// Normally implicitly ok in Delphi, due to type system - can't assign something else
// However, node uses a union / case to write to the same value, theoretically
// only for other tree types, so worth checking
assert((Node.btColor = rbRed) or (Node.btColor = rbBlack));
if Node = nil then Exit;
VerifyNodesRedOrBlack(Node.LeftChild);
VerifyNodesRedOrBlack(Node.RightChild);
end;
procedure TtdRedBlackTree.VerifyRootIsBlack;
begin
assert(IsBlack(FBinTree.Root));
end;
procedure TtdRedBlackTree.VerifyRedBlackRelationship(const Node : PtdBinTreeNode);
begin
// Every red node has two black children; or, the parent of every red node is black.
if IsRed(Node) then begin
assert(IsBlack(Node.LeftChild));
assert(IsBlack(Node.RightChild));
assert(IsBlack(Node.Parent));
end;
if Node = nil then Exit;
VerifyRedBlackRelationship(Node.LeftChild);
VerifyRedBlackRelationship(Node.RightChild);
end;
procedure VerifyBlackNodeCountHelper(const Node : PtdBinTreeNode; BlackCount : NativeInt; var PathBlackCount : NativeInt);
begin
if IsBlack(Node) then begin
Inc(BlackCount);
end;
if Node = nil then begin
if PathBlackCount = -1 then begin
PathBlackCount := BlackCount;
end else begin
assert(BlackCount = PathBlackCount);
end;
Exit;
end;
VerifyBlackNodeCountHelper(Node.LeftChild, BlackCount, PathBlackCount);
VerifyBlackNodeCountHelper(Node.RightChild, BlackCount, PathBlackCount);
end;
procedure TtdRedBlackTree.VerifyBlackNodeCount(const Node : PtdBinTreeNode);
var
PathBlackCount : NativeInt;
begin
// All paths from a node to its leaves contain the same number of black nodes.
PathBlackCount := -1;
VerifyBlackNodeCountHelper(Node, 0, PathBlackCount);
end;
旋转和其他有用的树方法
辅助方法检查一个节点是否是根节点，将一个节点设置为根，用另一个节点替换一个节点，执行左右旋转，以及沿着一棵树从右侧节点到叶子。使这些受保护的成员成为红黑树类。
procedure TtdRedBlackTree.RotateLeft(Node: PtdBinTreeNode);
var
R : PtdBinTreeNode;
begin
R := Node.RightChild;
ReplaceNode(Node, R);
Node.btChild[ctRight] := R.LeftChild;
if R.LeftChild <> nil then begin
R.LeftChild.btParent := Node;
end;
R.btChild[ctLeft] := Node;
Node.btParent := R;
end;
procedure TtdRedBlackTree.RotateRight(Node: PtdBinTreeNode);
var
L : PtdBinTreeNode;
begin
L := Node.LeftChild;
ReplaceNode(Node, L);
Node.btChild[ctLeft] := L.RightChild;
if L.RightChild <> nil then begin
L.RightChild.btParent := Node;
end;
L.btChild[ctRight] := Node;
Node.btParent := L;
end;
procedure TtdRedBlackTree.ReplaceNode(OldNode, NewNode: PtdBinTreeNode);
begin
if IsRoot(OldNode) then begin
SetRoot(NewNode);
end else begin
if OldNode.IsLeft then begin // // Is the left child of its parent
OldNode.Parent.btChild[ctLeft] := NewNode;
end else begin
OldNode.Parent.btChild[ctRight] := NewNode;
end;
end;
if NewNode <> nil then begin
newNode.btParent := OldNode.Parent;
end;
end;
function TtdRedBlackTree.IsRoot(const Node: PtdBinTreeNode): Boolean;
begin
Result := Node = FBinTree.Root;
end;
procedure TtdRedBlackTree.SetRoot(Node: PtdBinTreeNode);
begin
Node.btColor := rbBlack; // Root is always black
FBinTree.SetRoot(Node);
Node.btParent.btColor := rbBlack; // FHead is black
end;
function TtdRedBlackTree.MaximumNode(Node: PtdBinTreeNode): PtdBinTreeNode;
begin
assert(Node <> nil);
while Node.RightChild <> nil do begin
Node := Node.RightChild;
end;
Result := Node;
end;
插入和删除
红黑树是内部树的包装器，FBinTree. 这段代码以一种过度连接的方式直接修改了树。两者FBinTree和包装器红黑树都保留了FCount节点数的计数，为了使这个更干净，我删除TtdBinarySearchTree了（红黑树的祖先）FCount并重定向Count到 return FBinTree.Count，即询问实际的内部树搜索树和红黑树类使用 - 毕竟是拥有节点的东西。我还添加了通知方法NodeInserted并NodeRemoved增加和减少计数。不包括代码（微不足道）。
我还提取了一些用于分配节点和处理节点的方法——不要从树中插入或删除，或者对节点的连接或存在做任何事情；这些是为了照顾节点本身的创建和销毁。请注意，节点创建需要将节点的颜色设置为红色 - 在此之后会处理颜色更改。这也确保了当一个节点被释放时，有机会释放与其关联的数据。
function TtdBinaryTree.NewNode(const Item : Pointer): PtdBinTreeNode;
begin
{allocate a new node }
Result := BTNodeManager.AllocNode;
Result^.btParent := nil;
Result^.btChild[ctLeft] := nil;
Result^.btChild[ctRight] := nil;
Result^.btData := Item;
Result.btColor := rbRed; // Red initially
end;
procedure TtdBinaryTree.DisposeNode(Node: PtdBinTreeNode);
begin
// Free whatever Data was pointing to, if necessary
if Assigned(FDispose) then FDispose(Node.btData);
// Free the node
BTNodeManager.FreeNode(Node);
// Decrement the node count
NodeRemoved;
end;
使用这些额外的方法，使用以下代码进行插入和删除。代码已注释，但我建议您阅读原始页面以及 Delphi 书籍，以了解旋转的解释以及代码测试的各种情况。
插入
procedure TtdRedBlackTree.Insert(aItem : pointer);
var
NewNode, Node : PtdBinTreeNode;
Comparison : NativeInt;
begin
Verify;
newNode := FBinTree.NewNode(aItem);
assert(IsRed(NewNode)); // new node is red
if IsRoot(nil) then begin
SetRoot(NewNode);
NodeInserted;
end else begin
Node := FBinTree.Root;
while True do begin
Comparison := FCompare(aItem, Node.btData);
case Comparison of
0: begin
// Equal: tree doesn't support duplicate values
assert(false, 'Should not insert a duplicate item');
FBinTree.DisposeNode(NewNode);
Exit;
end;
-1: begin
if Node.LeftChild = nil then begin
Node.btChild[ctLeft] := NewNode;
Break;
end else begin
Node := Node.LeftChild;
end;
end;
else begin
assert(Comparison = 1, 'Only -1, 0 and 1 are valid comparison values');
if Node.RightChild = nil then begin
Node.btChild[ctRight] := NewNode;
Break;
end else begin
Node := Node.RightChild;
end;
end;
end;
end;
NewNode.btParent := Node; // Because assigned to left or right child above
NodeInserted; // Increment count
end;
InsertCase1(NewNode);
Verify;
end;
// Node is now the root of the tree. Node must be black; because it's the only
// node, there is only one path, so the number of black nodes is ok
procedure TtdRedBlackTree.InsertCase1(Node: PtdBinTreeNode);
begin
if not IsRoot(Node) then begin
InsertCase2(Node);
end else begin
// Node is root (the less likely case)
Node.btColor := rbBlack;
end;
end;
// New node has a black parent: all properties ok
procedure TtdRedBlackTree.InsertCase2(Node: PtdBinTreeNode);
begin
// If it is black, then everything ok, do nothing
if not IsBlack(Node.Parent) then InsertCase3(Node);
end;
// More complex: uncle is red. Recolor parent and uncle black and grandparent red
// The grandparent change may break the red-black properties, so start again
// from case 1.
procedure TtdRedBlackTree.InsertCase3(Node: PtdBinTreeNode);
begin
if IsRed(Node.Uncle) then begin
Node.Parent.btColor := rbBlack;
Node.Uncle.btColor := rbBlack;
Node.Grandparent.btColor := rbRed;
InsertCase1(Node.Grandparent);
end else begin
InsertCase4(Node);
end;
end;
// "In this case, we deal with two cases that are mirror images of one another:
// - The new node is the right child of its parent and the parent is the left child
// of the grandparent. In this case we rotate left about the parent.
// - The new node is the left child of its parent and the parent is the right child
// of the grandparent. In this case we rotate right about the parent.
// Neither of these fixes the properties, but they put the tree in the correct form
// to apply case 5."
procedure TtdRedBlackTree.InsertCase4(Node: PtdBinTreeNode);
begin
if (Node.IsRight) and (Node.Parent = Node.Grandparent.LeftChild) then begin
RotateLeft(Node.Parent);
Node := Node.LeftChild;
end else if (Node.IsLeft) and (Node.Parent = Node.Grandparent.RightChild) then begin
RotateRight(Node.Parent);
Node := Node.RightChild;
end;
InsertCase5(Node);
end;
// " In this final case, we deal with two cases that are mirror images of one another:
// - The new node is the left child of its parent and the parent is the left child
// of the grandparent. In this case we rotate right about the grandparent.
// - The new node is the right child of its parent and the parent is the right child
// of the grandparent. In this case we rotate left about the grandparent.
// Now the properties are satisfied and all cases have been covered."
procedure TtdRedBlackTree.InsertCase5(Node: PtdBinTreeNode);
begin
Node.Parent.btColor := rbBlack;
Node.Grandparent.btColor := rbRed;
if (Node.IsLeft) and (Node.Parent = Node.Grandparent.LeftChild) then begin
RotateRight(Node.Grandparent);
end else begin
assert((Node.IsRight) and (Node.Parent = Node.Grandparent.RightChild));
RotateLeft(Node.Grandparent);
end;
end;
删除
procedure TtdRedBlackTree.Delete(aItem : pointer);
var
Node,
Predecessor,
Child : PtdBinTreeNode;
begin
Node := bstFindNodeToDelete(aItem);
if Node = nil then begin
assert(false, 'Node not found');
Exit;
end;
if (Node.LeftChild <> nil) and (Node.RightChild <> nil) then begin
Predecessor := MaximumNode(Node.LeftChild);
Node.btData := aItem;
Node := Predecessor;
end;
assert((Node.LeftChild = nil) or (Node.RightChild = nil));
if Node.LeftChild = nil then
Child := Node.RightChild
else
Child := Node.LeftChild;
if IsBlack(Node) then begin
Node.btColor := NodeColor(Child);
DeleteCase1(Node);
end;
ReplaceNode(Node, Child);
if IsRoot(Node) and (Child <> nil) then begin
Child.btColor := rbBlack;
end;
FBinTree.DisposeNode(Node);
Verify;
end;
// If Node is the root node, the deletion removes one black node from every path
// No properties violated, return
procedure TtdRedBlackTree.DeleteCase1(Node: PtdBinTreeNode);
begin
if IsRoot(Node) then Exit;
DeleteCase2(Node);
end;
// Node has a red sibling; swap colors, and rotate so the sibling is the parent
// of its former parent. Continue to one of the next cases
procedure TtdRedBlackTree.DeleteCase2(Node: PtdBinTreeNode);
begin
if IsRed(Node.Sibling) then begin
Node.Parent.btColor := rbRed;
Node.Sibling.btColor := rbBlack;
if Node.IsLeft then begin
RotateLeft(Node.Parent);
end else begin
RotateRight(Node.Parent);
end;
end;
DeleteCase3(Node);
end;
// Node's parent, sibling and sibling's children are black; paint the sibling red.
// All paths through Node now have one less black node, so recursively run case 1
procedure TtdRedBlackTree.DeleteCase3(Node: PtdBinTreeNode);
begin
if IsBlack(Node.Parent) and
IsBlack(Node.Sibling) and
IsBlack(Node.Sibling.LeftChild) and
IsBlack(Node.Sibling.RightChild) then
begin
Node.Sibling.btColor := rbRed;
DeleteCase1(Node.Parent);
end else begin
DeleteCase4(Node);
end;
end;
// Node's sibling and sibling's children are black, but node's parent is red.
// Swap colors of sibling and parent Node; restores the tree properties
procedure TtdRedBlackTree.DeleteCase4(Node: PtdBinTreeNode);
begin
if IsRed(Node.Parent) and
IsBlack(Node.Sibling) and
IsBlack(Node.Sibling.LeftChild) and
IsBlack(Node.Sibling.RightChild) then
begin
Node.Sibling.btColor := rbRed;
Node.Parent.btColor := rbBlack;
end else begin
DeleteCase5(Node);
end;
end;
// Mirror image cases: Node's sibling is black, sibling's left child is red,
// sibling's right child is black, and Node is the left child. Swap the colors
// of sibling and its left sibling and rotate right at S
// And vice versa: Node's sibling is black, sibling's right child is red, sibling's
// left child is black, and Node is the right child of its parent. Swap the colors
// of sibling and its right sibling and rotate left at the sibling.
procedure TtdRedBlackTree.DeleteCase5(Node: PtdBinTreeNode);
begin
if Node.IsLeft and
IsBlack(Node.Sibling) and
IsRed(Node.Sibling.LeftChild) and
IsBlack(Node.Sibling.RightChild) then
begin
Node.Sibling.btColor := rbRed;
Node.Sibling.LeftChild.btColor := rbBlack;
RotateRight(Node.Sibling);
end else if Node.IsRight and
IsBlack(Node.Sibling) and
IsRed(Node.Sibling.RightChild) and
IsBlack(Node.Sibling.LeftChild) then
begin
Node.Sibling.btColor := rbRed;
Node.Sibling.RightChild.btColor := rbBlack;
RotateLeft(Node.Sibling);
end;
DeleteCase6(Node);
end;
// Mirror image cases:
// - "N's sibling S is black, S's right child is red, and N is the left child of its
// parent. We exchange the colors of N's parent and sibling, make S's right child
// black, then rotate left at N's parent.
// - N's sibling S is black, S's left child is red, and N is the right child of its
// parent. We exchange the colors of N's parent and sibling, make S's left child
// black, then rotate right at N's parent.
// This accomplishes three things at once:
// - We add a black node to all paths through N, either by adding a black S to those
// paths or by recoloring N's parent black.
// - We remove a black node from all paths through S's red child, either by removing
// P from those paths or by recoloring S.
// - We recolor S's red child black, adding a black node back to all paths through
// S's red child.
// S's left child has become a child of N's parent during the rotation and so is
// unaffected."
procedure TtdRedBlackTree.DeleteCase6(Node: PtdBinTreeNode);
begin
Node.Sibling.btColor := NodeColor(Node.Parent);
Node.Parent.btColor := rbBlack;
if Node.IsLeft then begin
assert(IsRed(Node.Sibling.RightChild));
Node.Sibling.RightChild.btColor := rbBlack;
RotateLeft(Node.Parent);
end else begin
assert(IsRed(Node.Sibling.LeftChild));
Node.Sibling.LeftChild.btColor := rbBlack;
RotateRight(Node.Parent);
end;
end;
最后的笔记
- 我希望这是有用的！如果你觉得它有用，请留下评论说明你是如何使用它的。我很想知道。
- 它没有任何保证或保证。它通过了我的单元测试，但它们可能更全面——我真正能说的是，在 Delphi 代码失败的地方，这段代码成功了。谁知道它是否以其他方式失败。使用风险自负。我建议您为此编写测试。如果您确实发现了错误，请在此处发表评论！
- 玩得开心 ：）