BTree for Delphi
A few weeks back I posted an article on RemObjects blog regarding universal code, and how you with a little bit of care can write code that easily compiled with both Oxygene, Delphi and Freepascal. With emphasis on Oxygene.
The example I used was a BTree class that I originally ported from Delphi to Smart Pascal, and then finally to Oxygene to run under WebAssembly.
Long story short I was asked if I could port the code back to Delphi in its more or less universal form. Naturally there are small differences here and there, but nothing special that distinctly separates the Delphi version from Oxygene or Smart Pascal.
Why this version?
If you google BTree and Delphi you will find loads of implementations. They all operate more or less identical, using records and pointers for optimal speed. I decided to base my version on classes for convenience, but it shouldn’t be difficult to revert that to use records if you absolutely need it.
What I like about this BTree implementation is that it’s very functional. Its easy to traverse the nodes using the ForEach() method, you can add items using a number as an identifier, but it also supports string identifiers.
I also changed the typical data reference. The data each node represent is usually a pointer. I changed this to variant to make it more functional.
Well, here is the Delphi version as promised. Happy to help.
unit btree; interface uses System.Generics.Collections, System.Sysutils, System.Classes; type // BTree leaf object TQTXBTreeNode = class(TObject) public Identifier: integer; Data: variant; Left: TQTXBTreeNode; Right: TQTXBTreeNode; end; [Weak] TQTXBTreeProcessCB = reference to procedure (const Node: TQTXBTreeNode; var Cancel: boolean); EBTreeError = class(Exception); TQTXBTree = class(TObject) private FRoot: TQTXBTreeNode; FCurrent: TQTXBTreeNode; protected function GetEmpty: boolean; virtual; function GetPackedNodes: TList; public property Root: TQTXBTreeNode read FRoot; property Empty: boolean read GetEmpty; function Add(const Ident: integer; const Data: variant): TQTXBTreeNode; overload; virtual; function Add(const Ident: string; const Data: variant): TQTXBTreeNode; overload; virtual; function Contains(const Ident: integer): boolean; overload; virtual; function Contains(const Ident: string): boolean; overload; virtual; function Remove(const Ident: integer): boolean; overload; virtual; function Remove(const Ident: string): boolean; overload; virtual; function Read(const Ident: integer): variant; overload; virtual; function Read(const Ident: string): variant; overload; virtual; procedure Write(const Ident: string; const NewData: variant); overload; virtual; procedure Write(const Ident: integer; const NewData: variant); overload; virtual; procedure Clear; overload; virtual; procedure Clear(const Process: TQTXBTreeProcessCB); overload; virtual; function ToDataArray: TList; function Count: integer; procedure ForEach(const Process: TQTXBTreeProcessCB); destructor Destroy; override; end; implementation //############################################################################# // TQTXBTree //############################################################################# destructor TQTXBTree.Destroy; begin if FRoot nil then Clear(); inherited; end; procedure TQTXBTree.Clear; var lTemp: TList; x: integer; begin if FRoot nil then begin // pack all nodes to a linear list lTemp := GetPackedNodes(); try // release each node for x := 0 to ltemp.Count-1 do begin lTemp[x].Free; end; finally // dispose of list lTemp.Free; // reset pointers FCurrent := nil; FRoot := nil; end; end; end; procedure TQTXBTree.Clear(const Process: TQTXBTreeProcessCB); begin ForEach(Process); Clear(); end; function TQTXBTree.GetPackedNodes: TList; var LData: Tlist; begin LData := TList.Create(); ForEach( procedure (const Node: TQTXBTreeNode; var Cancel: boolean) begin LData.Add(Node); Cancel := false; end); result := LData; end; function TQTXBTree.GetEmpty: boolean; begin result := FRoot = nil; end; function TQTXBTree.Count: integer; var LCount: integer; begin ForEach( procedure (const Node: TQTXBTreeNode; var Cancel: boolean) begin inc(LCount); Cancel := false; end); result := LCount; end; function TQTXBTree.ToDataArray: TList; var Data: TList; begin Data := TList.Create(); ForEach( procedure (const Node: TQTXBTreeNode; var Cancel: boolean) begin Data.add(Node.data); Cancel := false; end); result := data; end; function TQTXBTree.Add(const Ident: string; const Data: variant): TQTXBTreeNode; begin result := Add( Ident.GetHashCode(), Data); end; function TQTXBTree.Add(const Ident: integer; const Data: variant): TQTXBTreeNode; var lNode: TQTXBtreeNode; begin LNode := TQTXBTreeNode.Create(); LNode.Identifier := Ident; LNode.Data := data; if FRoot = nil then FRoot := LNode; FCurrent := FRoot; while true do begin if (Ident FCurrent.Identifier) then begin if (FCurrent.right = nil) then begin FCurrent.right := LNode; break; end else FCurrent := FCurrent.right; end else break; end; result := LNode; end; function TQTXBTree.Read(const Ident: string): variant; begin result := Read( Ident.GetHashCode() ); end; function TQTXBTree.Read(const Ident: integer): variant; begin FCurrent := FRoot; while FCurrent nil do begin if (Ident Fcurrent.Identifier) then FCurrent := FCurrent.Right else begin result := FCUrrent.Data; break; end end; end; procedure TQTXBTree.Write(const Ident: string; const NewData: variant); begin Write( Ident.GetHashCode(), NewData); end; procedure TQTXBTree.Write(const Ident: integer; const NewData: variant); begin FCurrent := FRoot; while (FCurrent nil) do begin if (Ident Fcurrent.Identifier) then FCurrent := FCurrent.Right else begin FCurrent.Data := NewData; break; end end; end; function TQTXBTree.Contains(const Ident: string): boolean; begin result := Contains( Ident.GetHashCode() ); end; function TQTXBTree.Contains(const Ident: integer): boolean; begin result := false; if FRoot nil then begin FCurrent := FRoot; while ( (not Result) and (FCurrent nil) ) do begin if (Ident Fcurrent.Identifier) then FCurrent := FCurrent.Right else begin Result := true; break; end end; end; end; function TQTXBTree.Remove(const Ident: string): boolean; begin result := Remove( Ident.GetHashCode() ); end; function TQTXBTree.Remove(const Ident: integer): boolean; var LFound: boolean; LParent: TQTXBTreeNode; LReplacement, LReplacementParent: TQTXBTreeNode; LChildCount: integer; begin FCurrent := FRoot; LFound := false; LParent := nil; LReplacement := nil; LReplacementParent := nil; while (not LFound) and (FCurrent nil) do begin if (Ident FCurrent.Identifier) then begin LParent := FCurrent; FCurrent := FCurrent.right; end else LFound := true; if LFound then begin LChildCount := 0; if (FCurrent.left nil) then inc(LChildCount); if (FCurrent.right nil) then inc(LChildCount); if FCurrent = FRoot then begin case (LChildCOunt) of 0: begin FRoot := nil; end; 1: begin if FCurrent.right = nil then FRoot := FCurrent.left else FRoot :=FCurrent.Right; end; 2: begin LReplacement := FRoot.left; while (LReplacement.right nil) do begin LReplacementParent := LReplacement; LReplacement := LReplacement.right; end; if (LReplacementParent nil) then begin LReplacementParent.right := LReplacement.Left; LReplacement.right := FRoot.Right; LReplacement.left := FRoot.left; end else LReplacement.right := FRoot.right; end; end; FRoot := LReplacement; end else begin case LChildCount of 0: if (FCurrent.Identifier < LParent.Identifier) then Lparent.left := nil else LParent.right := nil; 1: if (FCurrent.Identifier < LParent.Identifier) then begin if (FCurrent.Left = NIL) then LParent.left := FCurrent.Right else LParent.Left := FCurrent.Left; end else begin if (FCurrent.Left = NIL) then LParent.right := FCurrent.Right else LParent.right := FCurrent.Left; end; 2: begin LReplacement := FCurrent.left; LReplacementParent := FCurrent; while LReplacement.right nil do begin LReplacementParent := LReplacement; LReplacement := LReplacement.right; end; LReplacementParent.right := LReplacement.left; LReplacement.right := FCurrent.right; LReplacement.left := FCurrent.left; if (FCurrent.Identifier < LParent.Identifier) then LParent.left := LReplacement else LParent.right := LReplacement; end; end; end; end; end; result := LFound; end; procedure TQTXBTree.ForEach(const Process: TQTXBTreeProcessCB); function ProcessNode(const Node: TQTXBTreeNode): boolean; begin if Node nil then begin if Node.left nil then begin result := ProcessNode(Node.left); if result then exit; end; Process(Node, result); if result then exit; if (Node.right nil) then begin result := ProcessNode(Node.right); if result then exit; end; end; end; begin ProcessNode(FRoot); end; end.
All “” are missing is the source code.
All “” are missing in the source code.
This code was initially record based (obviously), but when I ported it to Smart I went for TObject. Under JavaScript (which smart compiles to) TObject is just a tiny structure, and the overhead cannot be measured even. It also opens up for inheriting out leafs that can hold particular data. Its free code, change it as you see fit 🙂
This is not a correct implementation of a b-tree. Nodes are only added to the Right node and never the Left, effectively making this a linked-list.
The wordpress formatting have removed part of the logic sadly. You need to check the git repo