Problems with Promote() using the red-black tree implementation from The Tomes of Delphi

Question 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 :)

Question 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

Problems with Promote() using the red-black tree implementation from The Tomes of Delphi

The crashing code

Some non-working attempts at fixing it

Edit: Further notes

Edit: further further notes