我还没有通过检查 Tomes of Delphi 源代码并与算法或 Julian 的其他实现（高度优化的 EZDSL 库实现）进行比较来找出问题所在（因此是这个问题！），但是我改为重新实施Delete，并且为了更好的衡量标准Insert，基于示例Literate Programming 网站上红黑树的 C 代码 http://en.literateprograms.org/Red-black_tree_%28C%29，我发现的最清晰的红黑树例子之一。 （纯粹通过研究代码并验证它是否正确实现某些内容来找到错误实际上是一项相当困难的任务，特别是当你不完全理解算法时。我可以告诉你，我现在有了更好的理解！）树有很好的文档记录 - 我认为 Delphi 的 Tomes 更好地概述了树如此工作的原因，但此代码是可读实现的更好示例。
关于此的注意事项：
- 注释通常是直接引用页面对特定方法的解释。
- 尽管我已将过程 C 代码移至面向对象的结构，但移植起来相当容易。有一些小怪癖，例如巴克纳尔树有一个
FHead节点，其子节点是树的根，转换时必须注意这一点。 （测试经常测试节点的父节点是否为 NULL，作为测试节点是否为根节点的一种方式。我已将这个逻辑和其他类似的逻辑提取到辅助方法、节点或树方法。）
- 读者还可能发现红黑树上永远困惑的页面 http://www.eternallyconfuzzled.com/tuts/datastructures/jsw_tut_rbtree.aspx有用。虽然我在编写这个实现时没有使用它，但我可能应该使用它，如果这个实现中存在错误，我会在那里寻求见解。也是我在调试ToD的时候研究RB树时发现的第一页，提到了红黑树和红黑树之间的联系2-3-4 树 http://en.wikipedia.org/wiki/2%E2%80%933%E2%80%934_tree按名字。
- 如果还不清楚，此代码修改了 Delphi 示例中的 Tomes
TtdBinaryTree, TtdBinarySearchTree and TtdRedBlackTree在发现TDBinTre.pas (ToD页面源码下载 http://www.boyet.com/FixedArticles/DADSBook.html.) 要使用它，请编辑该文件。它不是一个新的实现，并且它本身并不完整。具体来说，它保留了 ToD 代码的结构，例如TtdBinarySearchTree不是以下的后代TtdBinaryTree但拥有一个作为成员（即包装它），使用FHead节点而不是 nil 父节点Root, etc.
- 原始代码已获得 MIT 许可。 （该网站正在转移到另一个许可证；当您检查它时，它可能已经改变。对于未来的读者，在撰写本文时，该代码肯定处于 MIT 许可证之下。）我不确定 Tomes 的许可证Delphi 代码；因为它在一本算法书中，所以假设您可以使用它可能是合理的 - 我认为它隐含在一本参考书中。就我而言，只要您遵守原始许可证，欢迎您使用它:) 如果有用，请发表评论，我想知道。
- Delphi 实现的 Tomes 的工作原理是使用祖先排序二叉树的插入方法进行插入，然后“提升”该节点。逻辑在这两个地方。该实现也实现了插入，然后进入多种情况来检查位置并通过显式旋转的方式修改它。这些旋转采用不同的方法（
RotateLeft and RotateRight），我发现这很有用 - ToD 代码讨论了旋转，但没有明确地将它们拉入单独的命名方法中。Delete类似：它涉及到许多案例。每个案例都在页面上进行了解释，并在我的代码中作为注释。其中一些是我命名的，但有些太复杂，无法放入方法名称，所以只是“case 4”、“case 5”等，并附有注释解释。
- 该页面还包含验证树结构和红黑属性的代码。我已经开始这样做作为编写单元测试的一部分，但尚未完全添加所有红黑树约束，因此也将此代码添加到树中。它仅存在于调试版本中，并断言是否出现错误，因此在调试中完成的单元测试将捕获问题。
- 该树现在通过了我的单元测试，尽管它们可能更广泛 - 我编写它们是为了使调试 Delphi 树的 Tomes 更简单。该代码不提供任何形式的保证或保证。考虑它未经测试。在使用之前编写测试。如果您发现错误，请发表评论:)
上代码吧！
节点修改
我向节点添加了以下辅助方法，以使代码在阅读时更具可读性。例如，原始代码经常通过测试（盲目转换为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代码扫描得更好，如果它说if IsBlack(Node) not if not IsRed(Node)，并获取颜色，包括处理零节点。请注意，这些需要保持一致 -IsRed例如，对于 nil 节点返回 false，因此 nil 节点是黑色的。 （这也与红黑树的属性以及通往叶子的路径上黑色节点的一致数量有关。）
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如果不在类定义中进行调试，则被声明为内联。如果不进行调试，该方法应该为空，并且有望被编译器完全删除。Verify在开头和结尾处调用Insert and Delete方法，以确保树在修改之前和之后都是正确的。
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回来FBinTree.Count，即询问二叉搜索树和红黑树类使用的实际内部树 - 毕竟它是拥有节点的东西。我还添加了通知方法NodeInserted and 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;
通过这些额外的方法，使用以下代码进行插入和删除。代码已注释，但我建议您阅读原始页面 http://en.literateprograms.org/Red-black_tree_%28C%29还有《Tomes of 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;
Deletion
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 代码失败的地方成功了。谁知道它是否会以其他方式失败。使用风险自负。我建议您为其编写测试。如果您发现错误，请在这里评论！
- 玩得开心 ：）
