I don't work with Pascal very often so I apologise if this question is basic. I am working on a binary file program that writes an array of custom made records to a binary file.
Eventually I want it to be able to write multiple arrays of different custom record types to one single binary file.
For that reason I thought I would write an integer first being the number of bytes that the next array will be in total. Then I write the array itself. I can then read the first integer type block - to tell me the size of the next blocks to read in directly to an array.
For example - when writing the binary file I would do something like this:
assignfile(f,MasterFileName);
{$I-}
reset(f,1);
{$I+}
n := IOResult;
if n<> 0 then
begin
{$I-}
rewrite(f);
{$I+}
end;
n:= IOResult;
If n <> 0 then
begin
writeln('Error creating file: ', n);
end
else
begin
SetLength(MyArray, 2);
MyArray[0].ID := 101;
MyArray[0].Att1 := 'Hi';
MyArray[0].Att2 := 'MyArray 0 - Att2';
MyArray[0].Value := 1;
MyArray[1].ID := 102;
MyArray[1].Att1:= 'Hi again';
MyArray[1].Att2:= MyArray 1 - Att2';
MyArray[1].Value:= 5;
SizeOfArray := sizeOf(MyArray);
writeln('Size of character array: ', SizeOfArray);
writeln('Size of integer var: ', sizeof(SizeOfArray));
blockwrite(f,sizeOfArray,sizeof(SizeOfArray),actual);
blockwrite(f,MyArray,SizeOfArray,actual);
Close(f);
Then you could re-read the file with something like this:
Assign(f, MasterFileName);
Reset(f,1);
blockread(f,SizeOfArray,sizeof(SizeOfArray),actual);
blockread(f,MyArray,SizeOfArray,actual);
Close(f);
This has the idea that after these blocks have been read that you can then have a new integer recorded and a new array then saved etc.
It reads the integer parts of the records in but nothing for the strings. The record would be something like this:
TMyType = record
ID : Integer;
att1 : string;
att2 : String;
Value : Integer;
end;
Any help gratefully received!!
TMyType = record
ID : Integer;
att1 : string; // <- your problem
That field att1 declared as string that way means that the record contains a pointer to the actual string data (att1 is really a pointer). The compiler manages this pointer and the memory for the associated data, and the string can be any (reasonable) length.
A quick fix for you would be to declare att1 something like string[64], for example: a string which can be at maximum 64 chars long. That would eliminate the pointer and use the memory of the record (the att1 field itself, which now is a special static array) as buffer for string characters. Declaring the maximum length of the string, of course, can be slightly dangerous: if you try to assign the string a string too long, it will be truncated.
To be really complete: it depends on the compiler; some have a switch to make your declaration "string" usable, making it an alias for "string[255]". This is not the default though. Consider also that using string[...] is faster and wastes memory.
You have a few mistakes.
MyArray is a dynamic array, a reference type (a pointer), so SizeOf(MyArray) is the size of a pointer, not the size of the array. To get the length of the array, use Length(MyArray).
But the bigger problem is saving long strings (AnsiStrings -- the usual type to which string maps --, WideStrings, UnicodeStrings). These are reference types too, so you can't just save them together with the record. You will have to save the parts of the record one by one, and for strings, you will have to use a function like:
procedure SaveStr(var F: File; const S: AnsiString);
var
Actual: Integer;
Len: Integer;
begin
Len := Length(S);
BlockWrite(F, Len, SizeOf(Len), Actual);
if Len > 0 then
begin
BlockWrite(F, S[1], Len * SizeOf(AnsiChar), Actual);
end;
end;
Of course you should normally check Actual and do appropriate error handling, but I left that out, for simplicity.
Reading back is similar: first read the length, then use SetLength to set the string to that size and then read the rest.
So now you do something like:
Len := Length(MyArray);
BlockWrite(F, Len, SizeOf(Len), Actual);
for I := Low(MyArray) to High(MyArray) do
begin
BlockWrite(F, MyArray[I].ID, SizeOf(Integer), Actual);
SaveStr(F, MyArray[I].att1);
SaveStr(F, MyArray[I].att2);
BlockWrite(F, MyArray[I].Value, SizeOf(Integer), Actual);
end;
// etc...
Note that I can't currently test the code, so it may have some little errors. I'll try this later on, when I have access to a compiler, if that is necessary.
Update
As Marco van de Voort commented, you may have to do:
rewrite(f, 1);
instead of a simple
rewrite(f);
But as I replied to him, if you can, use streams. They are easier to use (IMO) and provide a more consistent interface, no matter to what exactly you try to write or read. There are streams for many different kinds of I/O, and all derive from (and are thus compatible with) the same basic abstract TStream class.
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.
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 :)
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
My setting:
OS: Windows 7 SP1 (32 bits)
Ram: 4 Go
Processor: Intel Pentium D 3.00 GHz
Delphi XE
My simple test:
I performed a test running the following program:
program TestAssign;
{$APPTYPE CONSOLE}
uses
SysUtils,
Diagnostics;
type
TTestClazz = class
private
FIntProp: Integer;
FStringProp: string;
protected
procedure SetIntProp(const Value: Integer);
procedure SetStringProp(const Value: string);
public
property IntProp: Integer read FIntProp write SetIntProp;
property StringProp: string read FStringProp write SetStringProp;
end;
{ TTestClazz }
procedure TTestClazz.SetIntProp(const Value: Integer);
begin
if FIntProp <> Value then
FIntProp := Value;
end;
procedure TTestClazz.SetStringProp(const Value: string);
begin
if FStringProp <> Value then
FStringProp := Value;
end;
var
i, j: Integer;
stopw1, stopw2 : TStopwatch;
TestObj: TTestClazz;
begin
ReportMemoryLeaksOnShutdown := True;
//
try
TestObj := TTestClazz.Create;
//
try
j := 10000;
while j <= 100000 do
begin
///
/// assignement
///
stopw1 := TStopwatch.StartNew;
for i := 0 to j do
begin
TestObj.FIntProp := 666;
TestObj.FStringProp := 'Hello';
end;
stopw1.Stop;
///
/// property assignement using Setter
///
stopw2 := TStopwatch.StartNew;
for i := 0 to j do
begin
TestObj.IntProp := 666;
TestObj.StringProp := 'Hello';
end;
stopw2.Stop;
///
/// Log results
///
Writeln(Format('Ellapsed time for %6.d loops: %5.d %5.d', [j, stopw1.ElapsedMilliseconds, stopw2.ElapsedMilliseconds]));
//
Inc(j, 5000);
end;
//
Writeln('');
Write('Press Return to Quit...');
Readln;
finally
TestObj.Free
end
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
My (provisionnal) conclusion:
It seems that:
It's worth using Setter with property under some condition
The overhead of calling a method and performing a conditional test take less time than an assignement.
My question:
Are those findings valid under any other diffrent setting or just localized ones (exception)?
I would make the following observations:
The decision as to whether or not to use a setter should be based on factors like code maintenance, correctness, readability rather than performance.
Your benchmark is wholly unreasonable since the if statements evaluate to False every time. Real world code that sets properties would be likely to modify the properties a reasonable proportion of the time that the setter runs.
I would expect that for many real world examples, the setter would run faster without the equality test. If that test were to evaluate to True every time then clearly the code would be quicker without it.
The integer setter is practically free and in fact the setter is slower than the direct field access.
The time is spent in the string property. Here there is some real performance benefit due to the optimisation of the if test which avoids string assignment code if possible.
The setters would be faster if you inlined them, but not by a significant amount.
My belief is that any real world code would never be able to detect any of these performance differences. In reality the bottleneck will be obtaining the values passed to the setters rather than time spent in the setters.
The main situation where such if protection is valuable is where the property modification is expensive. For example, perhaps it involves sending a Windows message, or hitting a database. For a property backed by a field you can probably take it or leave it.
In the chatter in the comments Premature Optimization wonders why the comparison if FStringProp <> Value is quicker than the assignment FStringProp := Value. I investigated a little further and it wasn't quite as I had originally thought.
It turns out that if FStringProp <> Value is dominated by a call to System._UStrEqual. The two strings passed are not in fact the same reference and so each character has to be compared. However, this code is highly optimised and crucially there are only 5 characters to compare.
The call to FStringProp := Value goes to System._UStrAsg and since Value is a literal with negative reference count, a brand new string has to be made. The Pascal version of the code looks like this:
procedure _UStrAsg(var Dest: UnicodeString; const Source: UnicodeString); // globals (need copy)
var
S, D: Pointer;
P: PStrRec;
Len: LongInt;
begin
S := Pointer(Source);
if S <> nil then
begin
if __StringRefCnt(Source) < 0 then // make copy of string literal
begin
Len := __StringLength(Source);
S := _NewUnicodeString(Len);
Move(Pointer(Source)^, S^, Len * SizeOf(WideChar));
end else
begin
P := PStrRec(PByte(S) - SizeOf(StrRec));
InterlockedIncrement(P.refCnt);
end;
end;
D := Pointer(Dest);
Pointer(Dest) := S;
_UStrClr(D);
end;
The key part of this is the call to _NewUnicodeString which of course calls GetMem. I am not at all surprised that heap allocation is significantly slower than comparison of 5 characters.
Put 'Hello' const into a variable and use it for setting then do a test again