Home > Delphi, JavaScript, nodeJS, Object Pascal, OP4JS > Smart Pascal: BTree storage anyone?

Smart Pascal: BTree storage anyone?

February 1, 2017 Leave a comment Go to comments

btreeDictionaries are cool but they are only as good as the mechanisms supporting them. So I figured I could see if we could get more bang for the buck with a dedicated BTree class for Smart Pascal.

If you are wondering what on earth a BTree routine is, head over to Wikipedia and gander up on the technical side here: https://en.wikipedia.org/wiki/B-tree. In short it allows you to store some data connected to a string. Actually, its connected to a value identifier – but we can do a checksum of a string and use that as the key. So dictionary. Sort of.

What is special about the Smart Pascal version? Well, for one it doesn’t use pointers. And secondly you can save it to a stream. Typically classes like this don’t ship with a SaveToStream() method because it’s mostly intended to be used at runtime. But JavaScript have a few perks that force us to think differently.

Hope you enjoy it!


unit BTree;

interface

uses
  System.Types,
  System.Types.Convert,
  System.JSON,
  System.NameValuePairs,
  System.Streams,
  System.Stream.Writer,
  System.Stream.Reader;

type

  TBTreeNode = class(JObject)
  public
    Ident: integer;
    Data: variant;
    Left: TBTreeNode;
    Right: TBTreeNode;
  end;

  TBTreeFileItem = record
    fiIdent:  integer;
    fiData: variant;
  end;

  TBTreeProcess = procedure (const Node: TBTreeNode; var Cancel: boolean);

  TBTree = class(TObject)
  private
    FRoot:  TBTreeNode;
    FCurrent: TBTreeNode;
  public
    property  Root: TBTreeNode read FRoot;
    property  Empty: boolean read ( FRoot = nil );

    function  Add(const Ident: integer; const Data: variant): TBTreeNode;overload;virtual;
    function  Add(const Ident: string; const Data: variant): TBTreeNode;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: TBTreeProcess);overload;virtual;

    function  ToArray: TVarArray;
    function  ToString: string;
    function  Size: integer;

    function  ToJSON: string;
    procedure FromJSON(const Data: string);

    procedure SaveToStream(const Stream: TStream);
    procedure LoadFromStream(const Stream: TStream);

    procedure ForEach(const Process: TBTreeProcess);

    constructor Create;
  end;


implementation


(* These are the IO signatures used for storage *)
const
CNT_BTREE_STREAM_HEADER = $BABE0001;
CNT_BTREE_ITEM_HEADER = $0001BABE;

//#############################################################################
// TBTree
//#############################################################################

constructor TBTree.Create;
begin
  inherited Create;
  FRoot := nil;
  FCurrent := nil;
end;

procedure TBTree.Clear;
begin
  FCurrent := nil;
  FRoot := nil;
end;

procedure TBTree.Clear(const Process: TBTreeProcess);
begin
  ForEach(Process);
  Clear;
end;

function TBTree.ToJSON: string;
begin
  if FRoot<>nil then
    result := Json.stringify(FRoot);
end;

procedure TBTree.FromJSON(const Data: string);
begin
  if not empty then
    Clear;
  FRoot := TBTreeNode( JSON.Parse(data) );
end;

procedure TBTree.SaveToStream(const Stream: TStream);
var
  LWriter: TStreamWriter;
  LData: Array of TBTreeFileItem;
  LRaw: TByteArray;
  LItem: TBTreeFileItem;
begin

  (* First, cache up all the data in an array. We need to do this
     in order to write the node-count on top of the file *)
  ForEach( procedure (const Node: TBTreeNode; var Cancel: boolean)
  begin
    LItem.fiIdent := Node.Ident;
    LItem.fiData := Node.Data;
    LData.add(LItem);
  end);

  LWriter := TStreamWriter.Create(Stream);
  try
    (* Write the magic identifier for the file *)
    LWriter.WriteInteger(CNT_BTREE_STREAM_HEADER);

    (* Write the number of items in the file *)
    LWriter.writeinteger(LData.Count);

    (* Now write each item *)
    for LItem in LData do
    begin
      (* Convert variant to byte-array *)
      LRaw := TDataType.VariantToBytes(LItem.fiData);

      (* Write the identifier for the record *)
      LWriter.WriteInteger(CNT_BTREE_ITEM_HEADER);

      (* Write the item-id *)
      LWriter.WriteInteger(LItem.fiIdent);

      (* Write the # of bytes in the data section *)
      LWriter.WriteInteger(LRaw.Count);

      (* Write the data section *)
      LWriter.Write(LRaw);
    end;
  finally
    LWriter.free;
  end;
end;

procedure TBTree.LoadFromStream(const Stream: TStream);
var
  LReader: TStreamReader;
  LHead: integer;
  LId: integer;
  LBytes: integer;
  LRaw: TByteArray;
  LValue: variant;
  LCount: integer;
begin
  (* Flush content if not empty *)
  if not Empty then
    Clear;

  (* Setup the reader *)
  LReader := TStreamReader.Create(Stream);
  try

    (* Validate the header *)
    LHead := LReader.ReadInteger;
    if LHead = CNT_BTREE_STREAM_HEADER then
    begin
      (* Get the count *)
      LCount := LReader.ReadInteger;

      while LCount>0 do
      begin
        LHead := LReader.ReadInteger;
        if LHead = CNT_BTREE_ITEM_HEADER then
        begin
          (* Read the identifier *)
          LId := LReader.ReadInteger;

          (* read the # of bytes for the variant *)
          LBytes := LReader.ReadInteger;

          (* Flush any lingering data *)
          LRaw.Clear;

          (* Read the raw data that makes up the variant *)
          if LBytes>0 then
          begin
            LRaw := LReader.read(LBytes);

            (* Convert from bytes to intrinsic *)
            LValue := TDatatype.BytesToVariant(LRaw);

            (* Add to tree *)
            self.Add(Lid, LValue);
          end;

        end else
        raise EW3Exception.CreateFmt('Invalid item header, expected %d not %d',
        [CNT_BTREE_ITEM_HEADER,LHead]);

        dec(LCount);
      end;

    end else
    raise EW3Exception.CreateFmt('Invalid stream header, expected %d not %d',
    [CNT_BTREE_STREAM_HEADER,LHead]);

  finally
    LReader.free;
  end;
end;

function TBTree.Size: integer;
var
  LCount: integer;
begin
  ForEach( procedure (const Node: TBTreeNode; var Cancel: boolean)
    begin
      inc(LCount);
    end);
  result := LCount;
end;

function TBTree.ToArray: TVarArray;
var
  Data: TVarArray;
begin
  ForEach( procedure (const Node: TBTreeNode; var Cancel: boolean)
    begin
      Data.add(Node.Ident);
    end);
  result := data;
end;

function TBTree.ToString: string;
begin
  for var x in ToArray do
  begin
    result += TVariant.AsString(x) + #13;
  end;
end;

function TBTree.Add(const Ident: string; const Data: variant): TBTreeNode;
begin
  result := Add( TString.CalcCRC(Ident), Data);
end;

function TBTree.Add(const Ident: integer; const Data: variant): TBTreeNode;
var
  LNode:  TBTreeNode;
begin
  LNode := new TBTreeNode;
  LNode.Ident := Ident;
  LNode.Data := data;

  if (FRoot = nil) then
  FRoot := LNode;

  FCurrent := FRoot;

  while (true) do
  begin
    if (Ident < FCurrent.Ident) then
    begin
      if (FCurrent.left = nil) then
      begin
        FCurrent.left := LNode;
        break;
      end else
      FCurrent := FCurrent.left;
    end else
    if (Ident > FCurrent.Ident) 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 TBTree.Read(const Ident: string): variant;
begin
  result := Read( TString.CalcCRC(Ident) );
end;

function TBTree.Read(const Ident: integer): variant;
begin
  Result := unassigned;
  FCurrent := FRoot;
  while (FCurrent <> nil) do
  begin
    if (Ident < FCurrent.Ident) then
    FCurrent := Fcurrent.left else
    if (Ident > Fcurrent.Ident) then
    FCurrent := FCurrent.Right else
    begin
      result := FCUrrent.Data;
      break;
    end
  end;
end;

procedure TBTree.Write(const Ident: string; const NewData: variant);
begin
  Write(TString.CalcCRC(Ident), NewData);
end;

procedure TBTree.Write(const Ident: integer; const NewData: variant);
begin
  FCurrent := FRoot;
  while (FCurrent <> nil) do
  begin
    if (Ident < FCurrent.Ident) then
    FCurrent := Fcurrent.left else
    if (Ident > Fcurrent.Ident) then
    FCurrent := FCurrent.Right else
    begin
      FCurrent.Data := NewData;
      break;
    end
  end;
end;

function  TBTree.&Contains(const Ident: string): boolean;
begin
  result := &Contains(TString.CalcCRC(Ident));
end;

function TBTree.&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.Ident) then
      FCurrent := Fcurrent.left else

      if (Ident > Fcurrent.Ident) then
        FCurrent := FCurrent.Right else
      begin
        Result := true;
      end
    end;
  end;
end;

function TBTree.Remove(const Ident: string): boolean;
begin
  result := Remove(TString.CalcCRC(Ident));
end;

function TBTree.Remove(const Ident: integer): boolean;
var
  LFound: boolean;
  LParent: TBTreeNode;
  LChildCount: integer;
  LReplacement,
  LReplacementParent: TBTreeNode;
begin
  LFound := false;
  LParent := nil;
  FCurrent := FRoot;

  while (not LFound) and (FCurrent<>nil) do
  begin
    if (Ident < FCurrent.Ident) then
    begin
      LParent := FCurrent;
      FCurrent:= FCurrent.left;
    end else
    if (Ident > FCurrent.Ident) then
    begin
      LParent := FCurrent;
      FCurrent := FCurrent.right;
    end else
    begin
      LFound := true;
    end;

    if (LFound) then
    begin
      LChildCount:=0;
      if (FCurrent.left<>nil) then inc(LChildCount);
      if (FCurrent.right<>nil) then inc(LChildCount);
      //LChildCount := (if FCurrent.left <> nil then 1 else 0) + (if FCurrent.right <> nil then 1 else 0);
      if (FCurrent = FRoot) then
      begin
        case (LChildCOunt) of
        0: FRoot := nil;
        1: FRoot := if FCurrent.right = nil then FCurrent.left else FCurrent.Right;
        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.Ident < LParent.Ident) then
            Lparent.left  := nil else
            LParent.right := nil;
        1:  if (FCurrent.Ident < LParent.Ident) 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.Ident < LParent.Ident) then
              LParent.left := LReplacement else
              LParent.right := LReplacement;
            end;
          end;
        end;
      end;
  end;

  result := LFound;
end;

procedure TBTree.ForEach(const Process: TBTreeProcess);

  function ProcessNode(const Node: TBTreeNode): boolean;
  begin
    (* Default to false. If true is defined here, the operation
       has been canceled by the user *)
    result := false;

    if (Node <> nil) then
    begin

      (* Process left path first *)
      if (node.left <> nil) then
      begin
        result := ProcessNode(Node.left);
        if result then
        exit;
      end;

      (* process midpoint *)
      Process(Node, result);
      if result then
      exit;

      (* current right path *)
      if (Node.right <> nil) then
      begin
        result:=ProcessNode(Node.right);
        if result then
        exit;
      end;
    end;
  end;

begin
  ProcessNode(FRoot);
end;

end.
Advertisements
  1. No comments yet.
  1. No trackbacks yet.

Leave a Reply

Please log in using one of these methods to post your comment:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: