algorithm - 使用来自Delphi的Tomes的红黑树实现的Promote()问题

Question

我正在使用Julian Bucknall在他的著名著作The Tomes Of Delphi中编写的Red-Black树实现。源代码可以是downloaded here，我在Delphi 2010中按原样使用代码，并对TdBasics.pas进行了修改，以使其可以在现代版本的Delphi中进行编译（大多数情况下都将其注释掉了-只有少数定义是树代码所要求的。）

这是著名作者在经常推荐的书中的著名实现。我觉得我应该坚定地使用它。但是我在使用Delete()和Promote()时发生崩溃。退一步使用DUnit编写单元测试，这些问题很容易重现。一些示例代码是（我的DUnit测试中的代码片段）：

// 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语句。尽管这看起来合乎逻辑，但这只是一种天真的解决方法。我对旋转的理解不够充分，无法知道这是否有效，或者是否应该进行其他操作-这样做会导致另一个问题，如代码段后所述。 （请注意，此代码段在上面复制的代码片段下方有向左旋转的重复项，并且在此处也发生了相同的错误。）

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世界中都是众所周知的。但是崩溃很容易重现，使用从作者站点下载的本书源代码为该类编写了一些非常基本的单元测试。在过去十年中的某个时间，其他人也一定曾经使用过此代码，并且遇到了相同的问题（除非该错误是我的错误，并且我的代码和单元测试都错误地使用了该树。）我正在寻找有助于以下方面的答案：


识别并修复 Promote和该类中其他位置的所有错误。请注意，我还为基类 TtdBinarySearchTree编写了单元测试，并且所有这些都通过了。 （这并不意味着它是完美的-我可能没有发现失败的案例。但这有所帮助。）
查找代码的更新版本。朱利安（Julian）尚未发布任何 errata for the red-black tree implementation。
如果所有其他方法都失败了，请为Delphi寻找一个不同的，已知的红黑树的良好实现。我使用树来解决问题，而不是为了写树。如果需要的话，我会很乐意用另一种基础实现替换（给定好的许可条款等）。但是，鉴于书和代码的血统书，问题出奇的是，解决这些问题将帮助更多的人，而不仅仅是我。在Delphi社区广泛推荐的书。


编辑：进一步说明

评论员MBo指出了朱利安的 EZDSL library，其中包含红黑树的另一种实现。此版本通过的单元测试。我目前正在比较两个来源，以尝试查看算法的偏差，以查找错误。

一种可能性是仅使用EZDSL红黑树，而不是Delphi红黑树的Tomes，但是该库存在一些问题，使我不愿意使用它：它仅针对32位x86编写；一些方法仅在汇编中提供，而不是在Pascal中提供（尽管大多数方法有两个版本）；树的结构完全不同，例如使用光标指向节点而不是指针-这是一种完全有效的方法，但是它是一个示例，说明代码与ToD书中的“示例”代码有何不同，其中导航在语义上有所不同；在我看来，代码更难理解和使用：经过大量优化，变量和方法的命名不那么清晰，有多种魔术函数，节点结构实际上是联合/案例记录，压缩有关堆栈，队列，出队和列表，双向链接列表，跳过列表，树，二叉树和堆的详细信息，它们都在调试器中几乎难以理解的一种结构中，等等。我不想在生产中使用的代码我需要在哪里支持它，也不容易从中学习。 Delphi源代码的Tomes更具可读性和可维护性，但同时也是不正确的。你看到了两难的地方:)

我正在尝试对代码进行比较，以发现朱利安的实践代码（EZDSL）和他的教学代码（《 Delphi的托梅斯》）之间的区别。但是，这个问题仍然悬而未决，我将不胜感激。自出版以来的十二年来，我不是唯一使用德尔福书城中的红黑树的人:)

编辑：进一步的说明

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

Answer 1

通过检查Delphi源代码的Tomes并与算法或Julian的其他实现（经过高度优化的EZDSL库实现）进行比较，我还没有设法找出问题所在，但是我还是重新实现了基于示例C code for a red-black tree on the Literate Programming site，这也是我发现的红黑树最清晰的示例之一，并且Delete以及Insert也很好。 （实际上，仅通过遍历代码并验证其是否正确实现了一个错误，这实际上是一项艰巨的任务，尤其是当您不完全理解该算法时。我可以告诉您，我现在有了更好的理解！） tree的文档非常好-我认为Delphi的Tomes更好地概述了为什么树能够像它那样工作的原因，但是此代码是可读性更好的示例。

关于此的注意事项：


注释通常是页面对特定方法的解释中的直接引号。
尽管我已将过程C代码移至面向对象的结构，但移植起来非常容易。有一些较小的怪癖，例如具有FHead节点的Bucknall的树，其子节点是树的根，在转换时必须要注意。 （测试经常测试节点的父节点是否为NULL，以此来测试该节点是否为根节点。我已经将此方法以及其他类似的逻辑提取到辅助方法，节点或树方法中。）
读者可能还会发现Eternally Confuzzled page on red-black trees有用。尽管在编写此实现时没有使用过它，但我可能应该使用它，并且如果该实现中有错误，我将转向那里进行深入了解。这也是我在调试ToD时研究RB树时发现的第一页，其中提到了红黑树和2-3-4 trees之间的联系。
如果不清楚，此代码将修改在TtdBinaryTree（source code download on the ToD page）中找到的Delphi示例TtdBinarySearchTree，TtdRedBlackTree和TDBinTre.pas的Tomes。要使用它，请编辑该文件。这不是一个新的实现，也不是一个完整的实现。具体来说，它使用TtdBinarySearchTree节点而不是TtdBinaryTree的父代来保持ToD代码的结构，例如FHead不是Root的后代，而是拥有一个作为成员（即包装它）。等
原始代码是MIT许可的。 （该站点正在迁移到另一个许可证；在您检查该站点时，它可能已更改。对于将来的读者，在编写本文时，该代码肯定是在MIT许可证下的。）我不确定Tomes的许可证Delphi代码；因为它在算法书中，所以假设您可以使用它可能是合理的-我认为它隐含在参考书中。就我而言，只要您遵守原始许可证，就可以使用它：)我想知道，如果有用，请发表评论。
Delphi实现的Tomes通过使用先祖排序的二叉树的插入方法进行插入，然后“提升”节点来工作。逻辑在这两个地方中的任何一个中。此实现还实现了插入，然后涉及多种情况以检查位置并通过显式旋转对其进行修改。这些轮换在单独的方法（RotateLeft和RotateRight）中，我发现这很有用-ToD代码讨论轮换，但未明确将其拉入单独的命名方法。 Delete类似：它涉及许多情况。每个案例都在页面上进行了说明，并在我的代码中作为注释。我为其中的一些命名，但有些太复杂而无法放入方法名称，因此只有“情况4”，“情况5”等，并带有注释说明。
该页面还具有验证树的结构和红黑属性的代码。我已经在编写单元测试的过程中开始执行此操作，但是还没有完全添加所有红黑树约束，因此也将此代码添加到了树中。它仅存在于调试版本中，并断言是否有问题，因此在调试中完成的单元测试将捕获问题。
该树现在通过了我的单元测试，尽管它们可以进行更广泛的测试-我编写它们是为了简化Delphi树的Tomes调试。此代码不提供任何形式的保证。认为它未经测试。在使用前编写测试。如果发现错误，请发表评论：）


上代码！

节点修改

我在节点上添加了以下帮助器方法，以使代码在阅读时更具素养。例如，原始代码经常通过测试（盲转换为Delphi和未修改的ToD结构）来测试节点是否是其父节点的左子节点，而现在您可以测试if Node = Node.Parent.btChild[ctLeft] 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;

我还添加了其他方法，例如现有的 if Node.IsLeft then...，以测试其是否为黑色（如果IMO代码显示 IsRed()而不是 if IsBlack(Node)，则IMO代码会扫描得更好，并获得颜色，包括处理nil节点。请注意，这些需要保持一致-例如， if not IsRed(Node)对于一个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代码中相同方法的直接转换。如果未在类定义中进行调试，则将 IsRed声明为内联。如果未调试，则该方法应为空，并有望被编译器完全删除。在 Verify和 Verify方法的开始和结束处调用 Insert，以确保修改前后树都是正确的。

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;

插入和删除

红黑树是内部树 Delete的包装。该代码以一种过于联系的方式直接修改了树。 FBinTree和包装器红黑树都保留节点数 FBinTree，为了使它更干净，我删除了 FCount（红黑树的祖先）的 TtdBinarySearchTree并重定向 FCount返回 Count，即询问二进制搜索树和红黑树类使用的实际内部树-毕竟是拥有节点的东西。我还添加了通知方法 FBinTree.Count和 NodeInserted来增加和减少计数。不包括代码（琐碎的）。

我还提取了一些用于分配节点和处置节点的方法-不会从树中插入或删除节点，也不会对节点的连接或状态进行任何处理。这些都是为了照顾节点本身的创建和破坏。请注意，创建节点时需要将节点的颜色设置为红色-在此之后将进行颜色更改。这还确保释放节点时，就有机会释放与其关联的数据。

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的Tomes书，以获取有关旋转以及代码测试的各种情况的说明。

插入

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代码的Tomes失败了。谁知道它是否会以其他方式失败。使用风险自负。我建议您为此编写测试。如果确实发现错误，请在此处评论！
玩得开心 ：）