使用 The Tomes of Delphi 中的红黑树实现时的 Promotion() 问题

Posted 2023-03-11

技术标签:

【中文标题】使用 The Tomes of Delphi 中的红黑树实现时的 Promotion() 问题【英文标题】：Problems with Promote() using the red-black tree implementation from The Tomes of Delphi 【发布时间】：2013-04-29 08:51:00 【问题描述】：

我正在使用 Julian Bucknall 在他的著名书籍The Tomes Of Delphi 中编写的红黑树实现。源代码可以是downloaded here，我在Delphi 2010 中按原样使用代码，对TdBasics.pas 进行了修改以使其在现代版本的Delphi 中编译（主要是注释掉大部分内容——只有少数定义是树代码需要。）

这是一位著名作者的著名实现，在一本经常被推荐的书中。我觉得我应该在坚实的基础上使用它。但是我在使用Delete() 和Promote() 时遇到了崩溃。退一步用 DUnit 编写单元测试，这些问题很容易重现。一些示例代码是（来自我的 DUnit 测试的 sn-ps）：

// 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;

我在算法方面不够扎实，不知道如何在不引入进一步问题（不平衡或不正确的树）的情况下修复它。我知道，因为我已经尝试过 :)

崩溃代码

上述测试在Promote() 中删除项目时失败，在标记为!!! 的行上：

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（变成aNode.btParent）是nil，因此崩溃。检查树形结构，节点的父节点是根节点，它本身显然有一个nil 父节点。

修复它的一些无效尝试

我尝试对此进行简单的测试，并且仅在祖父母存在时才运行 if/then/else 语句。虽然这看起来合乎逻辑，但这是一种幼稚的解决方法。我不太了解轮换，无法知道这是否有效或者是否应该发生其他事情 - 这样做会导致另一个问题，在 sn-p 之后提到。（请注意，在上面复制的 sn-p 下面有一个重复的代码，用于左旋转，同样的错误也发生在那里。）

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;
...

使用此代码，对 Delete 的测试仍然失败，但更奇怪的是：在调用 Delete() 之后，对 Find() 的调用正确返回 nil，表明该项已被删除。但是，循环的最后一次迭代，删除第 6 项，导致TtdBinarySearchTree.bstFindItem 崩溃：

Walker := FBinTree.Root;
CmpResult := FCompare(aItem, Walker^.btData);

FBinTree.Root 是nil，调用FCompare 时崩溃。

所以 - 在这一点上，我可以说我的修改显然只会导致更多问题，而实现算法的代码还有其他更根本的问题。不幸的是，即使有这本书作为参考，我也无法弄清楚哪里出了问题，或者更确切地说，正确的实现是什么样的以及这里有什么不同。

我最初认为一定是我的代码错误地使用了树，导致了问题。这还是很有可能的！作者、这本书以及隐含的代码在 Delphi 世界中都是众所周知的。但是崩溃很容易重现，使用从作者网站下载的本书源代码为类编写一些非常基本的单元测试。在过去十年的某个时候，其他人一定也使用过这个代码，并且遇到了同样的问题（除非这个 bug 是我的，并且我的代码和单元测试都错误地使用了树。）我正在寻求帮助的答案：

识别并修复Promote 和班级其他地方的任何错误。请注意，我还为基类TtdBinarySearchTree 编写了单元测试，并且都通过了。（这并不意味着它是完美的 - 我可能没有发现失败的案例。但它有一些帮助。）查找代码的更新版本。 Julian 尚未发布任何errata for the red-black tree implementation。如果所有其他方法都失败了，请为 Delphi 找到一个不同的、已知良好的红黑树实现。我正在使用树来解决问题，而不是用于编写树的练习。如果必须，我很乐意用另一个替换底层实现（假设许可条款等）。然而，鉴于本书和代码的血统，问题是令人惊讶的，解决它们将帮助更多的人，而不仅仅是我——这是一个Delphi 社区广泛推荐的书。

编辑：进一步说明

评论者 MBo 指出 Julian 的 EZDSL library，其中包含红黑树的另一个实现。此版本的单元测试通过。我目前正在比较这两个来源，以尝试查看算法偏离的位置，以找到错误。

一种可能是简单地使用 EZDSL 红黑树，而不是 Tomes of Delphi 红黑树，但是这个库有一些问题让我不热衷于使用它：它是为 32 位编写的仅限 x86；某些方法仅在汇编中提供，而不是 Pascal（尽管大多数有两个版本）；树的结构完全不同，例如使用光标而不是指针指向节点 - 这是一种完全有效的方法，但代码与 ToD 书中的“示例”代码有多么不同，其中导航在语义上是不同的；在我看来，代码更难理解和使用：它进行了相当大的优化，变量和方法没有明确命名，有各种神奇的功能，节点结构实际上是一个联合/案例记录，挤压堆栈、队列、出队和列表、双链表、跳过列表、树、二叉树和堆的详细信息都在一个结构中，这在调试器中几乎无法理解等。这不是我热衷于在生产中使用的代码我需要在哪里支持它，也不是很容易学习。 The Tomes of Delphi 源代码更具可读性和可维护性……但也不正确。你看到了困境:)

我正在尝试比较代码，试图找出 Julian 的实践代码 (EZDSL) 和他的教学代码 (Tomes of Delphi) 之间的差异。但是这个问题仍然悬而未决，我仍然会很感激你的答案。自德尔福之书出版以来的十二年里，我不可能是唯一使用红黑树的人:)

编辑：进一步说明

我自己已经回答了这个问题（尽管提供了赏金。哎呀。）我很难通过检查代码并与算法的 ToD 描述进行比较来发现错误，因此我重新实现了基于一个很好的页面，描述了 MIT 许可的 C 实现附带的结构；详情如下。一个好处是我认为新的实现实际上更容易理解。

【问题讨论】：

【参考方案1】：

Bucknall 写道，他的二叉树实现使用虚拟头节点作为根节点的父节点（以避免特殊情况）。这个头是在构造函数中创建的：

  constructor TtdBinaryTree.Create
   ...
 allocate a head node, eventually the root node of the tree will be
   its left child
  FHead := BTNodeManager.AllocNodeClear;

并在第一个节点插入期间使用：

function TtdBinaryTree.InsertAt
  ...
  if the parent node is nil, assume this is inserting the root
  if (aParentNode = nil) then begin
    aParentNode := FHead;
    aChildType := ctLeft;
  end;

所以你"the node's parent is the root node, which obviously has a nil parent itself"的情况看起来很奇怪，除非你重写了关键方法

【讨论】：

我可能弄错了，指的是头节点 - 我必须检查一下。我根本没有重写方法；事实上，为了确保问题出在树代码本身，而不是我所做的任何事情，我故意恢复到本书提供的确切代码进行测试。我无法在D7中编译链接文件包，但修改后的源（boyet.com/FixedArticles/EZDSL.html）已成功编译并测试工作（D7和D2006都有添加）有趣 - 这是相同的数据结构，但不同的库（非常不同，查看代码 - 例如，其中大部分是 asm 优化的）由同一作者。我会在一两个小时后回来工作时进行调查。感谢您的链接！我已经编辑了我的问题以反映 EZDSL 库。你是对的，它有效，但它不是我热衷于使用的代码——它不清楚而且 IMO 不容易维护。我仍然想弄清楚 Delphi 版本有什么问题。毕竟，那是一本教学书，应该有清晰正确的示例代码——找到其中的错误对很多人来说都很有价值。【参考方案2】：

通过检查 Delphi 源代码并与算法或 Julian 的其他实现（高度优化的 EZDSL 库实现）进行比较，我无法找出问题所在（因此是这个问题！），但是 相反，我基于示例C code for a red-black tree on the Literate Programming site（我发现的红黑树最清晰的示例之一）重新实现了Delete，以及Insert。（实际上，纯粹通过打磨代码并验证它是否正确实现了某些东西来找到错误实际上是一项相当艰巨的任务，尤其是当您不完全理解算法时。我可以告诉您，我现在理解得更好了！）树的文档很好 - 我认为 Delphi 的 Tomes 更好地概述了树为何如此工作的原因，但此代码是可读实现的更好示例。

注意事项：

评论通常直接引自页面对特定方法的说明。虽然我已将过程 C 代码移至面向对象的结构，但移植起来非常容易。有一些小怪癖，例如 Bucknall 的树有一个 FHead 节点，其子节点是树的根，转换时必须注意这一点。（测试经常测试节点的父节点是否为 NULL，以此作为测试节点是否为根节点的一种方式。我已经将这个和其他类似的逻辑提取到辅助方法、节点或树方法中。）读者可能还会发现Eternally Confuzzled page on red-black trees 很有用。尽管我在编写此实现时没有使用它，但我可能应该使用它，如果此实现中有错误，我会转向那里寻求洞察力。这也是我在调试ToD时研究RB树时发现的第一页，其中提到了红黑树和2-3-4 trees之间的联系。如果不清楚，此代码会修改位于 TDBinTre.pas (source code download on the ToD page) 中的 Tomes of Delphi 示例 TtdBinaryTree、TtdBinarySearchTree 和 TtdRedBlackTree。要使用它，请编辑该文件。这不是一个新的实现，它本身并不完整。具体来说，它保留了 ToD 代码的结构，例如 TtdBinarySearchTree 不是 TtdBinaryTree 的后代，而是拥有一个作为成员（即包装它），使用 FHead 节点而不是 Root 的 nil 父节点等。原始代码是 MIT 许可的。（该站点正在迁移到另一个许可证；当您检查它时它可能已经更改。对于未来的读者，在撰写本文时，代码肯定是在 MIT 许可证下。）我不确定 Tomes 的许可证德尔福代码；由于它在算法书中，因此假设您可以使用它可能是合理的 - 我认为它隐含在参考书中。就我而言，只要您遵守原始许可证，欢迎您使用它：）如果有用请发表评论，我想知道。 The Tomes of Delphi 的实现通过使用祖先排序二叉树的插入方法进行插入，然后“提升”节点。逻辑在这两个地方之一。这个实现也实现了插入，然后进入一些案例来检查位置并通过显式旋转来修改它。这些旋转在不同的方法中（RotateLeft 和RotateRight），我觉得这很有用——ToD 代码讨论了旋转，但没有明确地将它们拉入单独的命名方法中。 Delete 是类似的：它涉及到许多情况。每个案例都在页面上进行了解释，并在我的代码中作为 cmets 进行了解释。其中一些是我命名的，但有些过于复杂，无法输入方法名称，因此只是“案例 4”、“案例 5”等，并由 cmets 解释。该页面还包含验证树结构和红黑属性的代码。作为编写单元测试的一部分，我已经开始这样做了，但还没有完全添加所有的红黑树约束，因此也将这段代码添加到了树中。它仅存在于调试版本中，并在出现问题时进行断言，因此在调试中完成的单元测试会发现问题。该树现在通过了我的单元测试，尽管它们可能更广泛 - 我编写它们是为了使调试 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()，以测试它是否为黑色（如果显示if IsBlack(Node) 而不是if not IsRed(Node)，IMO 代码扫描得更好，并获取颜色，包括处理零节点。注意这些需要保持一致 - 例如，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 如果不在类定义中调试，则声明为内联。如果不调试，该方法应该是空的，并有望被编译器完全删除。在Insert和Delete方法的开头和结尾调用Verify，以确保修改前后的树是正确的。

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 和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;

通过这些额外的方法，使用以下代码进行插入和删除。代码已注释，但我建议您阅读 original page 和 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 代码失败的地方，这段代码成功了。谁知道它是否以其他方式失败。使用风险自负。我建议您为此编写测试。如果您确实发现了错误，请在此处发表评论！玩得开心:)

【讨论】：

以上是关于使用 The Tomes of Delphi 中的红黑树实现时的 Promotion() 问题的主要内容，如果未能解决你的问题，请参考以下文章

delphi的case of 问题。

delphi中case of问题

delphi中的case of语句

Delphi 中的 procedure of object

Delphi：如何屏蔽line too long这个错误

delphi_Case...Of语句使用？