Problems with Promote() using the red-black tree i

Question

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

Answer 1

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 FHead node, 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, TtdBinarySearchTree and TtdRedBlackTree found in TDBinTre.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 as TtdBinarySearchTree not being a descendant of TtdBinaryTree but owning one as a member (ie wrapping it), using a FHead node instead of a nil parent to the Root, 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 (RotateLeft and RotateRight), which I find useful - the ToD code talks about rotations but doesn't explicitly pull them into separate named methods. Delete is 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 :)

Answer 2

Bucknall writes that his implementation of binary tree uses dummy head node as parent of root node (to avoid special cases). This head is created in constructor:

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

and used during the first node insertion:

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;

So your situation "the node's parent is the root node, which obviously has a nil parent itself" looks very strange unless you have rewritten the key methods