使用Delphi的Tomes中的红黑树实现Promote（）的问题 [英] Problems with Promote() using the red-black tree implementation from The Tomes of Delphi
问题描述
TdBasics.pas 让它在Delphi的现代版本中进行编译（大部分评论是大部分内容 - 树代码只需要一些定义。） 这是着名作家在一本经常推荐的书中的着名实现。我觉得我应该使用它坚实的地面。但是我使用 Delete（）和 Promote（）遇到崩溃。用DUnit回退写单元测试，这些问题很容易重现。一些示例代码是（来自我的DUnit测试的代码片段）：
//需要初始化树的测试从一个七个项目开始
const
NumInitialItems：Integer = 7;
...
//数据是一个int，而不是一个指针
函数比较（aData1，aData2：指针）：整数;
begin
如果NativeInt（aData1）< NativeInt（aData2）然后Exit（-1）;
如果NativeInt（aData1）> NativeInt（aData2）然后Exit（1）;
退出（0）;
结束
//将七个项目（0..6）添加到树中。 Node.Data是一个指针字段，只是转换。
procedure TestTRedBlackTree.SetUp;
var
循环：整数;
begin
FRedBlackTree：= TtdRedBlackTree.Create（Compare，nil）;
for Loop：= 0 to NumInitialItems - 1 do begin
FRedBlackTree.Insert（Pointer（Loop））;
结束
结束
...
//删除（）崩溃的第一个项目，无论是0或1或...
程序TestTRedBlackTree.TestDelete ;
var
aItem：指针;
循环：整数;
开始
为循环：= 1到NumInitialItems - 1做开始//如果0（nil）导致问题，但1失败
aItem：=指针（循环）;
检查（FRedBlackTree.Find（aItem）= aItem，'删除前未找到项目'）;
FRedBlackTree.Delete（aItem）;
检查（FRedBlackTree.Find（aItem）= nil，删除后找到的项）;
Check（FRedBlackTree.Count = NumInitialItems - Loop，'Item still in the tree'）;
结束
结束
我的算法不够稳固，无法引入更多的问题（不平衡）或者不正确的树。）我知道，因为我试过：）
崩溃代码
以上在中删除项目时， Promote（）在 !!! 的行上失败：
函数TtdRedBlackTree.rbtPromote（aNode：PtdBinTreeNode）
：PtdBinTreeNode;
var
父级：PtdBinTreeNode;
begin
{记下我们正在推广的节点的父节点}
父节点：= aNode ^ .btParent;
{在这两种情况下，有6个链接被破坏并重新构建：节点的
链接到其子节点，反之亦然，节点与其父节点
的链接，反之亦然，父母与父母的链接和副作用$ b $反之亦然;注意，节点的子节点可以是nil}
{促进一个左边的孩子=右边的父节点}
if（Parent ^ .btChild [ctLeft] = aNode）然后开始
父^ .btChild [ctLeft]：= aNode ^ .btChild [ctRight];
if（Parent ^ .btChild [ctLeft]<> nil）then
Parent ^ .btChild [ctLeft] ^。btParent：= Parent;
aNode ^ .btParent：= Parent ^ .btParent;
if（aNode ^ .btParent ^ .btChild [ctLeft] = Parent）then // !!!
aNode ^ .btParent ^ .btChild [ctLeft]：= aNode
else
aNode ^ .btParent ^ .btChild [ctRight]：= aNode;
aNode ^ .btChild [ctRight]：=父;
父^ .btParent：= aNode;
end
...
Parent.btParent （成为 aNode.btParent ）是 nil ，因此崩溃。检查树结构，节点的父节点是根节点，它显然有一个 nil 父本身。
一些我尝试简单地测试这个，只有当一个祖父母存在时才运行if / then / else语句，这个工作就是修复它的非工作尝试
虽然这似乎是合乎逻辑的，但这是一个天真的修复;我不明白旋转是否足以知道这是否有效，或者是否应该发生其他事情 - 而这样做会导致另一个问题，在片段之后提到。 （请注意，上面复制的代码下面的代码重复了左旋，同样的错误也出现在这里）。
如果aNode.btParent<> //然后开始// !!!祖父母不存在，因为父是根节点
if（aNode ^ .btParent ^ .btChild [ctLeft] = Parent）然后
aNode ^ .btParent ^ .btChild [ctLeft]：= aNode
else
aNode ^ .btParent ^ .btChild [ctRight]：= aNode;
aNode ^ .btChild [ctRight]：=父;
结束
父^ .btParent：= aNode;
...
使用此代码，删除测试仍然失败，但有些东西更奇怪的是：在调用Delete（）后，对Find（）的调用正确返回nil，表示该项被删除。但是，删除项目6的循环的最后一次迭代导致 TtdBinarySearchTree.bstFindItem 中的崩溃：
Walker：= FBinTree.Root;
CmpResult：= FCompare（aItem，Walker ^ .btData）;
FBinTree.Root 是 nil ，调用 FCompare 时崩溃。
所以 - 在这一点上可以告诉我的修改显然只是造成更多的问题，而另一些更根本的是，代码实现算法是错误的。不幸的是，即使有这本书作为参考，我也无法弄明白什么是错误的，或者说，正确的实现方式是什么样的，这里有什么不同。
我原本以为一直是我的代码不正确地使用树，导致问题。这还是很可能的！作者，这本书，因此隐含的代码在德尔福世界是众所周知的。但是崩溃是很容易重现的，使用从作者的网站下载的本书的源代码，为课程编写一些非常基本的单元测试。有人也必须在过去十年的某个时候使用这个代码，并遇到同样的问题（除非是我的错误，我的代码和单元测试都使用不正确的树。）我正在寻求帮助的答案：
- 识别和修复
中的任何错误，促进和课堂中的其他地方。请注意，我还为基类（TtdBinarySearchTree）编写了单元测试，并且这些都通过了。 （这并不意味着它是完美的 - 我可能没有发现失败的案例，但这是一些帮助。） - 查找代码的更新版本。 Julian尚未发布任何红黑树实施的勘误。
- 如果一切都失败，找到一个不同的，已知的很好的Delphi红黑树实现。我正在使用树来解决一个问题，而不是为了写一棵树。如果我不得不，我会很乐意用另一个（给定的许可条款等）来替换潜在的实现。然而，鉴于这本书和代码的谱系，问题是令人惊讶的，解决它们会帮助更多的人而不仅仅是我 - 这是一个广泛推荐的书在Delphi社区。
编辑：进一步说明
评论员MBo指出Julian的 EZDSL库，其中包含另一个红黑树的实现。该版本通过单元测试。我目前正在比较两个来源，试图查看算法偏离哪里，以找到错误。
一种可能性是简单地使用EZDSL红黑树，而不是德尔福的红帽红黑树，但图书馆有一些问题，使我不热衷于使用它：它仅用于32位x86;一些方法仅在汇编中提供，而不是Pascal（虽然大多数有两个版本）;树结构完全不同，例如使用光标到节点而不是指针 - 一个完全有效的方法，但是代码与ToD书中的示例代码的不同之处的示例，其中导航在语义上是不同的;在我看来，代码很难理解和使用：它是非常重要的优化，变量和方法不如清楚地命名，有各种魔术功能，节点结构实际上是一个联合/案例记录，压缩详细的堆栈，队列，出列和列表，双链表，跳过列表，树，二进制树和堆在一个结构中几乎不可理解的调试器等。它不是代码我很想在生产中使用在哪里我需要支持它，也不容易学习。 Delphi源代码的Tomes可读性更好，可维护性更高...但也不正确。你看到困境：）
我试图比较代码，试图找出朱利安的实践代码（EZDSL）和他的教学代码（德尔福的Tomes）之间的差异）但是这个问题仍然是开放的，我仍然会感谢你的回答。在出版以来的十二年里，我不可能是唯一一个使用德尔福的十二年红黑树的人物。）
编辑：进一步说明
我已经回答了这个问题（尽管提供了一个赏金，哎呀）。我无法通过检查代码并与ToD描述进行比较这个算法，所以我根据描述MIT许可的C实现所带来的结构的一个好的页面重新实现了有缺陷的方法;详情如下。一个好处是，我认为新的实现实际上更清楚了解。
我没有弄清楚什么是通过检查Delphi源代码的Tomes，并与算法或Julian的其他实现进行比较，大量优化的EZDSL库实现（因此这个问题！），而是我重新实现了删除，并且根据插入 。 org / Red-black_tree_％28C％29rel =nofollow> Literate Programming site上的一个红黑树的C代码，这是我发现的一个红黑树的最清楚的例子之一。 （实际上，通过研究代码并验证它是否正确地实现了某些错误，尤其是在您不完全理解算法的时候，其实很难找到一个bug，我可以告诉你，现在我有了更好的理解！）树有很好的记录 - 我认为德尔福的Tomes更好地概述了为什么树的工作原理，但这段代码是可读实现的一个更好的例子。
注意：
- 评论通常是页面对特定方法的解释的直接引用。
- 尽管我将过程C代码移植到面向对象的结构中，但是很容易移植。有一些小小的怪癖，如Bucknall的树有一个
FHead节点，孩子是树的根，你必须在转换时注意。 （测试经常测试一个节点的父节点是否为NULL作为测试节点是根节点的方法，我已经将这个和其他类似的逻辑提取到帮助方法，或者节点或树方法。） - 读者还可以在红黑树上找到永久困惑的页面有用。虽然我在编写这个实现时没有使用它，但我可能应该有，如果在这个实现中有错误，我将转向那里了解。这也是在调查ToD时研究RB树的第一页，提到红黑树与 2-3-4棵树按名称。
- 如果不清楚，这段代码修改了Delphi示例
TtdBinaryTree，TtdBinarySearchTree和TtdRedBlackTree在TDBinTre.pas（ ToD页面上的源代码下载。）要使用它，请编辑该文件。这不是一个新的实现，而是不完整的。具体来说，它保留了ToD代码的结构，如TtdBinarySearchTree不是TtdBinaryTree的后代，而是拥有一个作为成员（即包装它），使用FHead节点，而不是根等的零父母 - 原始代码是MIT许可的。 （该网站正在转移到另一个许可证;它可能已经更改了您检查的时间。对于未来的读者，在撰写本文时，代码肯定是在麻省理工学院的许可证下。）我不确定对Tomes的许可的Delphi代码;因为它在一本算法书中，假设你可以使用它可能是合理的 - 它在参考书中是隐含的，我认为。据我所知，只要您遵守原始许可证，欢迎使用它:)请留下评论，如果它是有用的，我想知道。
- Delphi实现的Tomes通过使用祖先排序的二进制树的插入方法进行插入，然后促进该节点。逻辑在这两个地方。该实现也实现插入，然后进入多个情况来检查位置并通过显式轮换进行修改。这些旋转是分开的方法（
RotateLeft和RotateRight），我觉得很有用 - ToD代码谈论旋转，没有明确地将它们拉入到单独的命名方法中。删除是类似的：它在很多情况下。每个案例都在页面上解释，并在我的代码中作为注释。其中一些我命名，但有些太复杂，不能放入方法名称，所以只是案例4，案例5等，并有意见解释。 - 页面也有代码来验证树的结构，以及红黑属性。我已经开始做这个作为单元测试的一部分，但还没有完全添加所有的红黑树约束，所以也添加了这个代码到树。它只存在于调试版本中，并且断言如果出现错误，因此在调试中完成的单元测试将会遇到问题。
- 树现在通过我的单元测试，尽管它们可以更多广泛 - 我写了他们来调试Delphi树的Tomes更简单。此代码不作任何形式的担保或保证。考虑未经测试在使用之前先写测试。请注意，如果您发现错误：）
代码！
< h1>节点修改
我将以下帮助方法添加到节点中，以便在阅读时使代码更有识字性。例如，如果Node = Node.Parent.btChild [ctLeft]然后通过测试（如果Delphi和未修改的ToD结构的盲转换），则原始代码通常会测试一个节点是否为其父级的左侧子节点。 。而现在您可以测试如果Node.IsLeft然后... 等。记录定义中的方法原型不包括在内以节省空间，但应该是显而易见的：）
函数TtdBinTreeNode.Parent：PtdBinTreeNode;
begin
assert（btParent<> nil，'Parent is nil'）;
结果：= btParent;
结束
函数TtdBinTreeNode.Grandparent：PtdBinTreeNode;
begin
assert（btParent<> nil，'Parent is nil'）;
结果：= btParent.btParent;
assert（Result<> nil，'祖父母是根节点的孩子'）;
结束
函数TtdBinTreeNode.Sibling：PtdBinTreeNode;
begin
assert（btParent<> nil，'Parent is nil'）;
如果@Self = btParent.btChild [ctLeft]然后
退出（btParent.btChild [ctRight]）
else
退出（btParent.btChild [ctLeft]）;
结束
函数TtdBinTreeNode.Uncle：PtdBinTreeNode;
begin
assert（btParent<> nil，'Parent is nil'）;
//如果祖父母只有一个孩子（root的孩子没有叔叔），可以为零
结果：= btParent.Sibling;
结束
函数TtdBinTreeNode.LeftChild：PtdBinTreeNode;
begin
结果：= btChild [ctLeft];
结束
函数TtdBinTreeNode.RightChild：PtdBinTreeNode;
begin
结果：= btChild [ctRight];
结束
函数TtdBinTreeNode.IsLeft：Boolean;
开始
结果：= @Self = Parent.LeftChild;
结束
函数TtdBinTreeNode.IsRight：Boolean;
begin
结果：= @Self = Parent.RightChild;
结束
我还添加了额外的方法，如现有的 IsRed（），以测试它是否是黑色的（如果IsBlack（Node）不是如果不是IsRed（Node），并获取颜色，包括处理一个nil节点。请注意，这些需要一致 - IsRed ，例如，返回false为零节点，所以一个零节点是黑色的（这也与红黑树的属性以及一条路径上一致的黑色节点的数量有关）。
函数IsBlack（aNode：PtdBinTreeNode）：boolean;
begin
结果：=不是IsRed（aNode）;
end;
函数NodeColor（aNode：PtdBinTreeNode）：TtdRBColor;
begin
如果aNode = nil then Exit（rbBlack）;
结果：= aNode.btColor;
end ;
红黑约束验证
如上所述，这些方法验证树的结构和红黑co nstraints，并且是原始C代码中相同方法的直接翻译。如果在类定义中没有调试，则验证被声明为内联。如果没有调试，该方法应该是空的，希望可以被编译器完全删除。 验证在插入和删除方法，以确保修改前后的树是正确的。
procedure TtdRedBlackTree.Verify;
begin
{$ ifdef DEBUG}
VerifyNodesRedOrBlack（FBinTree.Root）;
VerifyRootIsBlack;
// 3是隐式的
VerifyRedBlackRelationship（FBinTree.Root）;
VerifyBlackNodeCount（FBinTree.Root）;
{$ endif}
end;
程序TtdRedBlackTree.VerifyNodesRedOrBlack（const Node：PtdBinTreeNode）;
begin
//在Delphi中通常是隐含的，由于类型系统 - 不能分配别的东西
//但是，节点使用union / case写入相同的值，理论上
//仅适用于其他树类型，所以值得检查
assert（（Node.btColor = rbRed）或（Node.btColor = rbBlack））;
如果Node = nil then Exit;
VerifyNodesRedOrBlack（Node.LeftChild）;
VerifyNodesRedOrBlack（Node.RightChild）;
结束
程序TtdRedBlackTree.VerifyRootIsBlack;
begin
assert（IsBlack（FBinTree.Root））;
结束
程序TtdRedBlackTree.VerifyRedBlackRelationship（const Node：PtdBinTreeNode）;
begin
//每个红色节点有两个黑人孩子;或者，每个红色节点的父节点为黑色。
如果IsRed（Node）然后开始
assert（IsBlack（Node.LeftChild））;
assert（IsBlack（Node.RightChild））;
assert（IsBlack（Node.Parent））;
结束
如果Node = nil then Exit;
VerifyRedBlackRelationship（Node.LeftChild）;
VerifyRedBlackRelationship（Node.RightChild）;
结束
过程VerifyBlackNodeCountHelper（const Node：PtdBinTreeNode; BlackCount：NativeInt; var PathBlackCount：NativeInt）;
begin
如果IsBlack（Node）然后开始
Inc（BlackCount）;
结束
如果Node = nil然后开始
如果PathBlackCount = -1然后开始
PathBlackCount：= BlackCount;
end else begin
assert（BlackCount = PathBlackCount）;
结束
退出;
结束
VerifyBlackNodeCountHelper（Node.LeftChild，BlackCount，PathBlackCount）;
VerifyBlackNodeCountHelper（Node.RightChild，BlackCount，PathBlackCount）;
结束
程序TtdRedBlackTree.VerifyBlackNodeCount（const Node：PtdBinTreeNode）;
var
PathBlackCount：NativeInt;
begin
//从节点到其叶子的所有路径都包含相同数量的黑色节点。
PathBlackCount：= -1;
VerifyBlackNodeCountHelper（Node，0，PathBlackCount）;
结束
旋转和其他有用的树方法
检查节点是否是根节点的帮助方法，将节点设置为根节点，用另一节点替换一个节点，执行左右旋转，并按照右侧节点将树跟随到叶。使这些受保护的红黑树类成员。
程序TtdRedBlackTree.RotateLeft（Node：PtdBinTreeNode）;
var
R：PtdBinTreeNode;
begin
R：= Node.RightChild;
ReplaceNode（Node，R）;
Node.btChild [ctRight]：= R.LeftChild;
如果R.LeftChild<>然后开始
R.LeftChild.btParent：= Node;
结束
R.btChild [ctLeft]：= Node;
Node.btParent：= R;
结束
程序TtdRedBlackTree.RotateRight（Node：PtdBinTreeNode）;
var
L：PtdBinTreeNode;
begin
L：= Node.LeftChild;
ReplaceNode（Node，L）;
Node.btChild [ctLeft]：= L.RightChild;
如果L.RightChild<>然后开始
L.RightChild.btParent：= Node;
结束
L.btChild [ctRight]：= Node;
Node.btParent：= L;
结束
程序TtdRedBlackTree.ReplaceNode（OldNode，NewNode：PtdBinTreeNode）;
begin
if IsRoot（OldNode）then begin
SetRoot（NewNode）;
end else begin
如果OldNode.IsLeft然后开始// //是它的父项的左边的孩子
OldNode.Parent.btChild [ctLeft]：= NewNode;
end else begin
OldNode.Parent.btChild [ctRight]：= NewNode;
结束
结束
如果NewNode<> nil然后开始
newNode.btParent：= OldNode.Parent;
结束
结束
函数TtdRedBlackTree.IsRoot（const Node：PtdBinTreeNode）：Boolean;
begin
结果：= Node = FBinTree.Root;
结束
程序TtdRedBlackTree.SetRoot（Node：PtdBinTreeNode）;
begin
Node.btColor：= rbBlack; //根总是黑色
FBinTree.SetRoot（Node）;
Node.btParent.btColor：= rbBlack; // FHead是黑色的
结束;
函数TtdRedBlackTree.MaximumNode（Node：PtdBinTreeNode）：PtdBinTreeNode;
begin
assert（Node<> nil）;
，而Node.RightChild<> nil do begin
Node：= Node.RightChild;
结束
结果：= Node;
结束
插入和删除
黑树是内部树的包装， FBinTree 。该代码以太连接的方式直接修改树。 $ code> FBinTree 和包装红黑树保存节点数的计数 FCount ，并使这个更干净我删除了 TtdBinarySearchTree （红黑树的祖先） FCount 并重定向计数返回 FBinTree.Count ，即请求实际的内部树，二叉搜索树和红黑树类使用 - 这毕竟是拥有节点的东西。我还添加了通知方法 NodeInserted 和 NodeRemoved 以增加和减少计数。代码不包括（微不足道）。
我还提取了一些分配节点和处理节点的方法 - 不从树中插入或删除，也可以做任何关于节点的连接或存在;这些是为了照顾节点本身的创建和销毁。请注意，节点创建需要将节点的颜色设置为红色 - 此点后，颜色更改将被照看。这也确保了节点被释放时，有机会释放与之相关联的数据。
函数TtdBinaryTree.NewNode （const Item：Pointer）：PtdBinTreeNode;
begin
{分配一个新节点}
结果：= BTNodeManager.AllocNode;
结果^ .btParent：= nil;
结果^ .btChild [ctLeft]：= nil;
结果^ .btChild [ctRight]：= nil;
结果^ .btData：= Item;
Result.btColor：= rbRed; //红色最初
结束;
程序TtdBinaryTree.DisposeNode（Node：PtdBinTreeNode）;
begin
//任何数据指向的地方，如果需要，
如果分配（FDispose）然后FDispose（Node.btData）;
//释放节点
BTNodeManager.FreeNode（Node）;
//递减节点数
NodeRemoved;
结束
使用这些额外的方法，使用以下代码进行插入和删除。代码被评论，但我建议您阅读原始页面以及Tomes of德尔福的书籍解释，以及代码测试的各种情况。
插入
procedure TtdRedBlackTree.Insert（aItem：pointer）;
var
NewNode，Node：PtdBinTreeNode;
比较：NativeInt;
begin
验证;
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;
，而True开始
比较：= FCompare（aItem，Node.btData）;
case比较
0：begin
//等于：tree不支持重复值
assert（false，'不应该插入重复项'）;
FBinTree.DisposeNode（NewNode）;
退出;
结束
-1：begin
如果Node.LeftChild = nil然后开始
Node.btChild [ctLeft]：= NewNode;
休息;
end else begin
Node：= Node.LeftChild;
结束
结束
else begin
assert（比较= 1，'只有-1，0和1是有效的比较值'）;
如果Node.RightChild = nil然后开始
Node.btChild [ctRight]：= NewNode;
休息;
end else begin
Node：= Node.RightChild;
结束
结束
结束
结束
NewNode.btParent：= Node; //因为分配给左边或右边的孩子以上
NodeInserted; //递增计数
end;
InsertCase1（NewNode）;
验证;
结束
// Node现在是树的根。节点必须是黑色;因为它是唯一的
//节点，只有一个路径，所以黑色节点的数量是ok
程序TtdRedBlackTree.InsertCase1（Node：PtdBinTreeNode）;
begin
如果不是IsRoot（Node）然后开始
InsertCase2（Node）;
end else begin
//节点是根（不太可能的情况）
Node.btColor：= rbBlack;
结束
结束
//新节点有一个黑色父项：所有属性ok
程序TtdRedBlackTree.InsertCase2（Node：PtdBinTreeNode）;
begin
//如果它是黑色的，那么一切OK，不做任何
如果不是IsBlack（Node.Parent）然后InsertCase3（Node）;
结束
//更复杂：叔叔是红色的。重新父母和叔叔黑色和祖父母红色
//祖父母变化可能会破坏红黑属性，所以从案例1再次启动
//
程序TtdRedBlackTree.InsertCase3（节点：PtdBinTreeNode ）;
begin
如果IsRed（Node.Uncle）然后开始
Node.Parent.btColor：= rbBlack;
Node.Uncle.btColor：= rbBlack;
Node.Grandparent.btColor：= rbRed;
InsertCase1（Node.Grandparent）;
end else begin
InsertCase4（Node）;
结束
结束
//在这种情况下，我们处理两个相互镜像的情况：
// - 新节点是其父节点的正确子节点，父节点是在这种情况下，我们向左旋转父母
// - 新节点是其父节点的左子节点，父节点是对应的子节点
//这个祖父母，在这种情况下，我们围绕父进行右转。
//这两个都不修改属性，但是他们把树放在正确的形式
//来应用案例5。
procedure TtdRedBlackTree.InsertCase4（Node：PtdBinTreeNode）;
begin
if（Node.IsRight）和（Node.Parent = Node.Grandparent.LeftChild）然后开始
RotateLeft（Node.Parent）;
Node：= Node.LeftChild;
end else if（Node.IsLeft）和（Node.Parent = Node.Grandparent.RightChild）然后开始
RotateRight（Node.Parent）;
Node：= Node.RightChild;
结束
InsertCase5（Node）;
结束
//在这种最后一种情况下，我们处理两种是彼此镜像的情况：
// - 新节点是其父级的左边的子节点，父节点是左边的孩子
//祖父母，在这种情况下，我们围绕祖父母转动
// - 新节点是父节点的正确子节点，父节点是对的子节点$ b $在这种情况下，我们围绕祖父母左转。
//现在的属性是满意的，所有的案例都被覆盖了。
程序TtdRedBlackTree.InsertCase5（Node：PtdBinTreeNode）;
begin
Node.Parent.btColor：= rbBlack;
Node.Grandparent.btColor：= rbRed;
if（Node.IsLeft）和（Node.Parent = Node.Grandparent.LeftChild）然后开始
RotateRight（Node.Grandparent）;
end else begin
assert（（Node.IsRight）和（Node.Parent = Node.Grandparent.RightChild））;
RotateLeft（Node.Grandparent）;
结束
结束
删除
procedure TtdRedBlackTree.Delete（aItem：pointer）;
var
节点，
前身，
孩子：PtdBinTreeNode;
begin
Node：= bstFindNodeToDelete（aItem）;
如果Node = nil然后开始
assert（false，'Node not found'）;
退出;
结束
if（Node.LeftChild<> nil）和（Node.RightChild<> nil）然后开始
前导：= MaximumNode（Node.LeftChild）;
Node.btData：= aItem;
节点：=前任;
结束
assert（（Node.LeftChild = nil）或（Node.RightChild = nil））;
如果Node.LeftChild = nil then
Child：= Node.RightChild
else
Child：= Node.LeftChild;
如果IsBlack（Node）然后开始
Node.btColor：= NodeColor（Child）;
DeleteCase1（Node）;
结束
ReplaceNode（Node，Child）;
if IsRoot(Node) and (Child <> nil) then begin
Child.btColor := rbBlack;
结束
FBinTree.DisposeNode(Node);
Verify;
结束
// 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);
结束
// 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);
结束
结束
DeleteCase3(Node);
结束
// 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);
结束
结束
// 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);
结束
结束
// 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);
结束
DeleteCase6(Node);
结束
// 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 par ent 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);
结束
结束
Final notes
- I hope this is useful! If you found it useful, please leave a comment saying how you used it. I’d quite like to know.
- It comes with no warranty or guarantee whatsoever. It passes my unit tests, but they could be more comprehensive - all I can really say is that this code succeeds where the Tomes of Delphi code fails. Who knows if it fails in other ways. Use at your own risk. I recommend you write tests for it. If you do find a bug, please comment here!
- Have fun :)
I am using the Red-Black tree implementation written by Julian Bucknall in his well-known book, The Tomes Of Delphi. Source code can be downloaded here, and I am using the code as-is in Delphi 2010, with modifications to TdBasics.pas to let it compile in a modern version of Delphi (mostly commenting most of it out - only a few definitions are required by the tree code.)
This is a well-known implementation by a famous author, in an often-recommended book. I feel I should be on solid ground using it. But I am encountering crashes using Delete() and Promote(). Stepping back to write unit tests with DUnit, these problems are easily reproducible. Some example code is (snippets from my DUnit tests):
// Tests that require an initialised tree start with one with seven items
const
NumInitialItems : Integer = 7;
...
// Data is an int, not a pointer
function Compare(aData1, aData2: Pointer): Integer;
begin
if NativeInt(aData1) < NativeInt(aData2) then Exit(-1);
if NativeInt(aData1) > NativeInt(aData2) then Exit(1);
Exit(0);
end;
// Add seven items (0..6) to the tree. Node.Data is a pointer field, just cast.
procedure TestTRedBlackTree.SetUp;
var
Loop : Integer;
begin
FRedBlackTree := TtdRedBlackTree.Create(Compare, nil);
for Loop := 0 to NumInitialItems - 1 do begin
FRedBlackTree.Insert(Pointer(Loop));
end;
end;
...
// Delete() crashes for the first item, no matter if it is 0 or 1 or...
procedure TestTRedBlackTree.TestDelete;
var
aItem: Pointer;
Loop : Integer;
begin
for Loop := 1 to NumInitialItems - 1 do begin // In case 0 (nil) causes problems, but 1 fails too
aItem := Pointer(Loop);
Check(FRedBlackTree.Find(aItem) = aItem, 'Item not found before deleting');
FRedBlackTree.Delete(aItem);
Check(FRedBlackTree.Find(aItem) = nil, 'Item found after deleting');
Check(FRedBlackTree.Count = NumInitialItems - Loop, 'Item still in the tree');
end;
end;
I'm not solid enough in the algorithms to know how to fix it without introducing further problems (unbalanced or incorrect tree.) I know, because I've tried :)
The crashing code
The above test fails in Promote() when deleting an item, on the line marked !!!:
function TtdRedBlackTree.rbtPromote(aNode : PtdBinTreeNode)
: PtdBinTreeNode;
var
Parent : PtdBinTreeNode;
begin
{make a note of the parent of the node we're promoting}
Parent := aNode^.btParent;
{in both cases there are 6 links to be broken and remade: the node's
link to its child and vice versa, the node's link with its parent
and vice versa and the parent's link with its parent and vice
versa; note that the node's child could be nil}
{promote a left child = right rotation of parent}
if (Parent^.btChild[ctLeft] = aNode) then begin
Parent^.btChild[ctLeft] := aNode^.btChild[ctRight];
if (Parent^.btChild[ctLeft] <> nil) then
Parent^.btChild[ctLeft]^.btParent := Parent;
aNode^.btParent := Parent^.btParent;
if (aNode^.btParent^.btChild[ctLeft] = Parent) then //!!!
aNode^.btParent^.btChild[ctLeft] := aNode
else
aNode^.btParent^.btChild[ctRight] := aNode;
aNode^.btChild[ctRight] := Parent;
Parent^.btParent := aNode;
end
...
Parent.btParent (becoming aNode.btParent) is nil, thus the crash. Examining the tree structure, the node's parent is the root node, which obviously has a nil parent itself.
Some non-working attempts at fixing it
I tried simply testing for this and only running that if/then/else statement when a grandparent existed. While this seems logical, it's kind of a naive fix; I don't understand the rotations well enough to know if this is valid or if something else should happen instead - and doing so causes another problem, mentioned after the snippet. (Note there is a duplicate of this code below the snippet copied above for a left rotation, and the same bug occurs there too.)
if aNode.btParent <> nil then begin //!!! Grandparent doesn't exist, because parent is root node
if (aNode^.btParent^.btChild[ctLeft] = Parent) then
aNode^.btParent^.btChild[ctLeft] := aNode
else
aNode^.btParent^.btChild[ctRight] := aNode;
aNode^.btChild[ctRight] := Parent;
end;
Parent^.btParent := aNode;
...
Using this code, the test for Delete still fails, but with something more odd: after the call to Delete(), the call to Find() correctly returns nil, indicating the item was removed. However, the last iteration of the loop, removing item 6, causes a crash in TtdBinarySearchTree.bstFindItem:
Walker := FBinTree.Root;
CmpResult := FCompare(aItem, Walker^.btData);
FBinTree.Root is nil, crashing when calling FCompare.
So - at this point I can tell my modifications are clearly just causing more problems, and something else more fundamental is wrong with the code implementing the algorithm. Unfortunately, even with the book as reference, I can't figure out what is wrong, or rather, what a correct implementation would look like and what's different here.
I originally thought it must have been my code incorrectly using the tree, causing the problems. This is still very possible! The author, the book and thus implicitly the code are well-known in the Delphi world. But the crashes are easily reproducible, writing some very basic unit tests for the class, using the book's source code downloaded from the author's site. Someone else must have also used this code sometime in the past decade, and encountered the same problem (unless the bug is mine and both my code and unit tests are using the tree incorrectly.) I am seeking answers helping with:
- Identifying and fixing any bugs in
Promoteand elsewhere in the class. Note that I have also written unit tests for the base class,TtdBinarySearchTree, and those all pass. (That doesn't mean it's perfect - I might not have identified failing cases. But it's some help.) - Finding an updated version of the code. Julian hasn't published any errata for the red-black tree implementation.
- If all else fails, finding a different, known good implementation of a red-black tree for Delphi. I am using the tree to solve a problem, not for the exercise of writing a tree. If I have to, I will happily replace the underlying implementation with another (given okay licensing terms etc.) Nevertheless, given the pedigree of the book and code, problems are surprising, and solving them would help more people than just me - it's a widely recommended book in the Delphi community.
Edit: Further notes
Commenter MBo points out Julian's EZDSL library, which contains another implementation of a red-black tree. Unit tests on this version pass. I am currently comparing the two sources to try to see where the algorithms deviate, to find the bug.
One possibility is to simply use the EZDSL red-black tree, not the Tomes of Delphi red-black tree, but there are a few problems with the library that make me not keen to use it: It's written for 32-bit x86 only; some methods are provided in assembly only, not Pascal (though most have two versions); the trees are structured quite differently, such as using cursors to nodes instead of pointers - a perfectly valid approach, but an example of how different the code is to the 'example' code in the ToD book, where navigation is semantically different; the code is, in my opinion, much harder to understand and use: it's quite heavily optimised, variables and methods are as not as clearly named, there are a variety of magic functions, the node structure is actually a union / case record, squishing in details for stacks, queues, dequeues and lists, double-linked-lists, skips lists, trees, binary trees and heaps all in one structure that is almost incomprehensible in the debugger, etc. It's not code I am keen to use in production where I will need to support it, nor is it easy to learn from. The Tomes of Delphi source code is much more readable and much more maintainable... but also incorrect. You see the dilemma :)
I am attempting to compare the code to try to find differences between Julian's in-practice code (EZDSL) and his teaching code (Tomes of Delphi.) But this question is still open and I will still be grateful for answers. I can't be the only person to use the red-black trees from the Tomes of Delphi in the twelve years since it was published :)
Edit: further further notes
I've answered this myself (in spite of offering a bounty. Oops.) I had trouble finding the bugs purely by examining the code and comparing to the ToD description of the algorithm, so instead I reimplemented the flawed methods based on a good page describing the structure that came with a MIT-licensed C implementation; details below. One bonus is that I think the new implementation is actually much clearer to understand.
I haven't managed to figure out what's wrong by examining the Tomes of Delphi source code and comparing to either the algorithm or Julian's other implementation, the heavily-optimised EZDSL library implementation (thus this question!), but I have instead re-implemented Delete, and for good measure also Insert, based on the example C code for a red-black tree on the Literate Programming site, one of the clearest examples of a red-black tree I found. (It's actually quite a hard task to find a bug purely by grinding through the code and verifying it implements something correctly, especially when you don't fully understand the algorithm. I can tell you, I have a much better understanding now!) The tree is quite well documented - I think the Tomes of Delphi gives a better overview of the reasons for why the tree works as it does, but this code is a better example of a readable implementation.
Notes about this:
- Comments are often direct quotes from the page's explanation of particular methods.
- It was quite easy to port over, though I've moved the procedural C code to an object-oriented structure. There are some minor quirks such as Bucknall's tree having a
FHeadnode, the child of which is the tree's root, which you have to be aware of when converting. (Tests often tested if a node's parent was NULL as a way of testing if the node was the root node. I have extracted this and other similar logic to helper methods, or node or tree methods.) - Readers may also find the Eternally Confuzzled page on red-black trees useful. Although I didn't use it when writing this implementation, I probably should have, and if there are bugs in this implementation I will turn there for insight. It was also the first page I found when researching RB trees when debugging the ToD one to mention the connection between red-black trees and 2-3-4 trees by name.
- In case it's not clear, this code modifies the Tomes of Delphi example
TtdBinaryTree,TtdBinarySearchTreeandTtdRedBlackTreefound inTDBinTre.pas(source code download on the ToD page.) To use it, edit that file. It's not a new implementation, and isn't complete on its own. Specifically, it keeps the ToD code's structure, such asTtdBinarySearchTreenot being a descendant ofTtdBinaryTreebut owning one as a member (ie wrapping it), using aFHeadnode instead of a nil parent to theRoot, etc. - The original code is MIT-licensed. (The site is moving to another license; it may have changed by the time you check it. For future readers, at the time of writing, the code was definitely under the MIT license.) I am not certain of the license to the Tomes of Delphi code; since it's in an algorithms book, it's probably reasonable to assume you can use it - it's implicit in a reference book, I think. As far as I'm concerned, so long as you comply with the original licenses, you are welcome to use it :) Please leave a comment if it is useful, I'd like to know.
- The Tomes of Delphi's implementation works by inserting using the ancestor sorted binary tree's insertion method, and then "promoting" the node. Logic is in either of these two places. This implementation implements the insertion as well, and then goes into a number of cases to check the position and modify it by means of explicit rotations. These rotations are in separate methods (
RotateLeftandRotateRight), which I find useful - the ToD code talks about rotations but doesn't explicitly pull them into separate named methods.Deleteis similar: it goes into a number of cases. Each case is explained on the page, and as comments in my code. Some of these I named, but some are too complex to put in a method name, so are just "case 4", "case 5" etc, with comments explaining. - The page also had code to verify the structure of the tree, and the red-black properties. I had started doing this as part of writing unit tests but hadn't yet fully added all the red-black tree constraints, and so added this code to the tree too. It's only present in a debug build, and asserts if something is wrong, so unit tests done in debug will catch problems.
- The tree now passes my unit tests, although they could be much more extensive - I wrote them to make debugging the Tomes of Delphi tree simpler. This code has no warranty or guarantee of any kind. Consider it untested. Write tests before you use it. Please comment if you find a bug :)
On to the code!
Node modifications
I added the following helper methods to the node, to make the code more literate when reading. For example, the original code often tested if a node was the left child of its parent by testing (blind conversion to Delphi and unmodified ToD structures) if Node = Node.Parent.btChild[ctLeft] then... whereas now you can test if Node.IsLeft then... etc. The method prototypes in the record definition aren't included to save space, but should be obvious :)
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;
I also added extra methods like the existing IsRed(), to test if it is black (IMO code scans nicer if it says if IsBlack(Node) not if not IsRed(Node), and to get the colour, including handling a nil node. Note that these need to be consistent - IsRed, for example, returns false for a nil node, so a nil node is black. (This also ties in to the properties of a red-black tree, and the consistent number of black nodes on a path to a leaf.)
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;
Red-black constraint verification
As mentioned above, these methods verify the structure of the tree and the red-black constraints, and are a direct translation of the same methods in the original C code. Verify is declared as inline if not debug in the class definition. If not debug, the method should be empty and will hopefully be completely removed by the compiler. Verify is called at the beginning and end of the Insert and Delete methods, to ensure the tree was correct before and after modification.
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;
Rotations and other useful tree methods
Helper methods to check if a node is the root node, to set a node as the root, to replace one node with another, to perform left and right rotations, and to follow a tree down the right-hand nodes to the leaf. Make these protected members of the red-black tree class.
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;
Insertion and deletion
The red-black tree is a wrapper around an internal tree, FBinTree. In a too-connected manner this code modifies the tree directly. Both FBinTree and the wrapper red-black tree keep a count FCount of the number of nodes, and to make this cleaner I removed TtdBinarySearchTree (the ancestor of the red-black tree)'s FCount and redirected Count to return FBinTree.Count, i.e. ask the actual internal tree that the binary search tree and red-black tree classes use - which is after all the thing that owns the nodes. I've also added notification methods NodeInserted and NodeRemoved to increment and decrement the counts. Code not included (trivial).
I also extracted some methods for allocating a node and disposing of a node - not to insert or delete from the tree or do anything about a node's connections or presence; these are to look after creation and destruction of a node itself. Note that node creation needs to set the node's color to red - color changes are looked after after this point. This also ensures that when a node is freed, there is an opportunity to free the data associated with it.
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;
With these extra methods, use the following code for insertion and deletion. Code is commented, but I recommend you read the original page and also the Tomes of Delphi book for an explanation of rotations, and the various cases that the code tests for.
Insertion
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;
Final notes
- I hope this is useful! If you found it useful, please leave a comment saying how you used it. I'd quite like to know.
- It comes with no warranty or guarantee whatsoever. It passes my unit tests, but they could be more comprehensive - all I can really say is that this code succeeds where the Tomes of Delphi code fails. Who knows if it fails in other ways. Use at your own risk. I recommend you write tests for it. If you do find a bug, please comment here!
- Have fun :)
这篇关于使用Delphi的Tomes中的红黑树实现Promote（）的问题的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
