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

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

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

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

我没有想出通过检查Delphi源代码的Tomes和比较算法或Julian的其他实现,大量优化的EZDSL库实现(因此这个问题！),但是我重新实现了删除,并且为了很好的测量也插入,基于示例 C code for a red-black tree on the Literate Programming site,我发现一个红黑树的最清楚的例子之一. (实际上,通过研究代码并验证它是否正确地实现了某些错误,尤其是在您不完全理解算法的时候,其实很难找到一个bug,我可以告诉你,现在我有了更好的理解！)树有很好的记录 – 我认为Delphi的Tomes更好地概述了为什么树的工作原理,但是这个代码是可读实现的一个更好的例子.

注意事项：

>评论通常是页面对特定方法的解释的直接引用.
>这是很容易的移植,虽然我把程序化的C代码移植到面向对象的结构.有一些小小的怪癖,如Bucknall的树有一个FHead节点,孩子是树的根,你必须注意转换. (如果节点的父节点为NULL,则经常测试测试节点是根节点的方法,我已经将这个和其他类似的逻辑提取到帮助方法,或者节点或树方法).
>读者也可能发现Eternally Confuzzled page on red-black trees有用.虽然我在编写这个实现时没有使用它,但我可能应该有,如果在这个实现中有错误,我将转向那里了解.这也是我在调查ToD时研究RB树的第一个页面,提到红黑树和2-3-4 trees之间的连接名称.
>如果不清楚,这段代码修改了Delphi中的Tomes示例TtdBinaryTree,TtdBinarySearchTree和TtdRedBlackTree在TDBinTre.pas(source code download on the ToD page)中找到.要使用它,请编辑该文件.这不是一个新的实现,而是不完整的.具体来说,它保持ToD代码的结构,例如TtdBinarySearchTree不是TtdBinaryTree的后代,而是拥有一个作为成员(即包装它),使用FHead节点而不是Root的零父项等.
>原始代码是MIT许可的. (该网站正在转移到另一个许可证;它可能已经更改了您检查的时间.对于未来的读者,在撰写本文时,代码肯定是在麻省理工学院的许可证下.)我不确定对Tomes的许可的Delphi代码;因为它在一本算法书中,假设你可以使用它可能是合理的 – 它在参考书中是隐含的,我认为.就我而言,只要你符合原始许可证,欢迎使用它:)请留下评论,如果它是有用的,我想知道.
> Delphi实现的Tomes通过使用祖先排序的二叉树插入方法进行插入,然后“促进”节点.逻辑在这两个地方.该实现也实现插入,然后进入多个情况来检查位置并通过显式轮换进行修改.这些旋转是单独的方法(RotateLeft和RotateRight),我觉得很有用 – ToD代码谈论旋转,但没有明确地将它们拉到单独的命名方法.删除是类似的：它进入一些情况.每个案例都在页面上解释,并在我的代码中作为注释.其中一些我命名,但有些太复杂,不能放入一个方法名称,所以只是“案例4”,“案例5”等,并有注释解释.
>该页面还有代码来验证树的结构,以及红黑属性.我已经开始做这个作为单元测试的一部分,但还没有完全添加所有的红黑树约束,所以也添加了这个代码到树.它仅存在于调试版本中,并且断言如果出现错误,因此在调试中完成的单元测试将会遇到问题.
>树现在通过我的单元测试,虽然它们可以更广泛 – 我写了他们来调试Delphi树的Tomes更简单.此代码不作任何形式的担保或保证.考虑未经测试在使用之前先写测试.请注意,如果你发现一个错误:)

到代码！

节点修改

我向节点添加了以下帮助方法,以便在阅读时使代码更有文字性.例如,如果Node = Node.Parent.btChild [ctLeft]然后…,则原始代码通常通过测试(盲目转换为Delphi和未修改的ToD结构)来测试节点是否为其父级的左侧子节点,而现在您可以测试如果Node.IsLeft然后…等等.记录定义中的方法原型不包括在内,以节省空间,但应该是明显的:)

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()等额外的方法来测试它是否为黑色(如果IsBlack(Node)如果不是IsRed(Node)IsBlack(Node)),并且得到颜色,那么IMO代码扫描更好,包括处理一个nil节点请注意,这些需要保持一致 – 例如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代码中相同方法的直接转换.如果类定义中没有调试,则验证被声明为内联.如果没有调试,该方法应该是空的,希望可以被编译器完全删除.验证在插入和删除方法的开头和结尾调用,以确保修改前后的树是正确的.

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

插入和删除

红黑树是内部树FBITree周围的包装.该代码以太连接的方式直接修改树. FBinTree和包装红黑树都保留了一个计数节点的数量,并使这个更清洁我删除了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以及德尔福的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失败了.谁知道是否以其他方式失败使用您自己的风险.我建议你为它编写测试.如果你发现错误,请在这里评论！有乐趣:)