ezdslbtr.pas

Eazy Data Structures library for Delphi.

{===EZDSLBTR==========================================================

Part of the Delphi Structures Library--the binary tree, the binary
search tree and the red-black binary search tree.

EZDSLBTR is Copyright (c) 1993-2002 by  Julian M. Bucknall

VERSION HISTORY
12Feb02 JMB 3.03 Release for Delphi 6
24Oct99 JMB 3.02 Release for Delphi 4 & 5
19Apr98 JMB 3.00 Major new version, release for Delphi 3
24May96 JMB 2.01 removal of (some) warnings for Delphi 2
13Mar96 JMB 2.00 release for Delphi 2.0
18Jun95 JMB 1.00 conversion of EZStrucs to Delphi
=====================================================================}
{ Copyright (c) 1993-2002, Julian M. Bucknall. All Rights Reserved   }

unit EZDSLBtr;

{$I EzdslDef.inc}
{---Place any compiler options you require here----------------------}


{--------------------------------------------------------------------}
{$I EzdslOpt.inc}

interface

uses
  SysUtils,
  {$IFDEF Windows}
  WinTypes,
  WinProcs,
  {$ENDIF}
  {$IFDEF Win32}
  Windows,
  {$ENDIF}
  {$IFDEF Linux}
  Types,
  Libc,
  {$ENDIF}
  Classes,
  {$IFDEF ThreadsExist}
  EzdslThd,
  {$ENDIF}
  EzdslCts,
  EzdslSup,
  EzdslBse,
  EzdslStk,
  EzdslQue;

type
  TBinTree = class(TAbstractContainer)
    {-Binary tree object}
    private
      btRt           : PNode;
      btTravType     : TTraversalType;
      btUseRecursion : boolean;
    protected
      procedure btInsertPrim(var Cursor : TTreeCursor; aNode : PNode); virtual;
    public
      constructor Create(DataOwner : boolean); override;
      constructor Clone(Source : TAbstractContainer;
                        DataOwner : boolean; NewCompare : TCompareFunc); override;

      function Delete(Cursor : TTreeCursor) : TTreeCursor; virtual;
      procedure Empty; override;
      function Erase(Cursor : TTreeCursor) : TTreeCursor;
      function Examine(Cursor : TTreeCursor) : pointer;
      procedure Insert(var Cursor : TTreeCursor; aData : pointer); virtual;
      function IsLeaf(Cursor : TTreeCursor) : boolean;
      function IsRoot(Cursor : TTreeCursor) : boolean;
      function Iterate(Action : TIterator; Backwards : boolean;
                        ExtraData : pointer) : TTreeCursor;
      procedure Join(Cursor : TTreeCursor; Tree : TBinTree); virtual;
      function Left(Cursor : TTreeCursor) : TTreeCursor;
      function Parent(Cursor : TTreeCursor) : TTreeCursor;
      function Replace(Cursor : TTreeCursor; aData : pointer) : pointer; virtual;
      function Right(Cursor : TTreeCursor) : TTreeCursor;
      function Root : TTreeCursor;
      function Search(var Cursor : TTreeCursor; aData : pointer) : boolean; virtual;

      property TraversalType : TTraversalType
         read btTravType
         write btTravType;
      property UseRecursion : boolean
         read btUseRecursion
         write btUseRecursion;
  end;

  TBinSearchTree = class(TBinTree)
    {-Binary search tree object}
    protected
      procedure acSort; override;
      procedure bsSortTraverse(aNode : PNode);
      procedure bsSwapData(OldCursor, NewCursor : TTreeCursor); virtual;
    public
      constructor Create(DataOwner : boolean); override;
      constructor Clone(Source : TAbstractContainer;
                        DataOwner : boolean; NewCompare : TCompareFunc); override;

      function Delete(Cursor : TTreeCursor) : TTreeCursor; override;
      procedure Insert(var Cursor : TTreeCursor; aData : pointer); override;
      procedure Join(Cursor : TTreeCursor; Tree : TBinTree); override;
      function Replace(Cursor : TTreeCursor; aData : pointer) : pointer; override;
      function Search(var Cursor : TTreeCursor; aData : pointer) : boolean; override;
  end;

  TrbSearchTree = class(TBinSearchTree)
    {-Balanced binary search tree object (Red-black tree)}
    private
      rbDeletedNodeWasBlack : boolean;

    protected
      procedure btInsertPrim(var Cursor : TTreeCursor; aNode : PNode); override;
      procedure bsSwapData(OldCursor, NewCursor : TTreeCursor); override;
      function rbPromote(Cursor : TTreeCursor) : TTreeCursor;

    public
      function Delete(Cursor : TTreeCursor) : TTreeCursor; override;
  end;

{$IFDEF ThreadsExist}
type
  TThreadsafeBinTree = class
    protected {private}
      btBinTree : TBinTree;
      btResLock : TezResourceLock;
    protected
    public
      constructor Create(aDataOwner : boolean);
      destructor Destroy; override;

      function AcquireAccess : TBinTree;
      procedure ReleaseAccess;
  end;

  TThreadsafeBinSearchTree = class
    protected {private}
      bstBinSearchTree : TBinSearchTree;
      bstResLock       : TezResourceLock;
    protected
    public
      constructor Create(aDataOwner : boolean);
      destructor Destroy; override;

      function AcquireAccess : TBinSearchTree;
      procedure ReleaseAccess;
  end;

  TThreadsafeRBSearchTree = class
    protected {private}
      rbstrbSearchTree : TrbSearchTree;
      rbstResLock      : TezResourceLock;
    protected
    public
      constructor Create(aDataOwner : boolean);
      destructor Destroy; override;

      function AcquireAccess : TrbSearchTree;
      procedure ReleaseAccess;
  end;
{$ENDIF}

implementation

{Notes: the TTreeCursor is a pointer and a boolean wrapped in one. In
        Delphi, pointers allocated on the heap have a granularity of
        4 bytes, ie their offset always has the lower 2 bits clear.
        We use bit 0 of the pointer as a left child, right child
        indicator (left = 0, right = 1). Thus the TTreeCursor is a
        pointer to the parent's node and an indicator to the relevant
        child.
        The parent link field of a node (the PKC) is a pointer and two
        booleans wrapped in one. The pointer is the parent's node as
        for TTreeCursors, bit 0 is the child (so a node always knows
        which child it is) and we use bit 1 of the pointer as a color
        bit for red-black trees (black = 0, red = 1). This by the way
        violates pure OOP design where ancestor aren't supposed to
        'know' about their descendants, but as I wrote the binary
        tree implementations in one go...
        Note that given a node you can easily calculate the
        TTreeCursor value for that node: just set the color bit of the
        PKC to 0 (the routine to use is Bleach).
        The following 6 routines all help maintain these 'packed'
        variables.                                                    }

{-Given a cursor, returns the address of node's parent node}
function Dad(X : TTreeCursor) : PNode;
{$IFDEF Windows}
inline($58/            {pop ax      get offset}
       $25/$FC/$FF/    {and ax, XX  clear color and child bits}
       $5A);           {pop dx      get seg/sel}
{$ELSE}
begin
  Result := PNode(X and $FFFFFFFC);
end;
{$ENDIF}
{--------}
{-Given a cursor, returns the child relationship the node has with its parent}
function Kid(X : TTreeCursor) : TChild;
{$IFDEF Windows}
inline($58/            {pop ax      get offset}
       $25/$01/$00/    {and ax, 1   isolate child bit}
       $5A);           {pop dx      toss seg/sel}
{$ELSE}
begin
  Result := TChild(X and $1);
end;
{$ENDIF}
{--------}
{-Given a cursor, returns the address of the node being pointed to}
function GetNode(Cursor : TTreeCursor) : PNode;
{$IFDEF Windows}
near; assembler;
asm
  mov ax, Cursor.Word[2]
  mov es, ax
  mov di, Cursor.Word[0]
  mov ax, di
  and ax, $FFFC
  xchg ax, di
  and ax, 1
  shl ax, 1
  shl ax, 1
  add di, ax
  mov ax, es:[di+4]
  mov dx, es:[di+6]
end;
{$ELSE}
register;
asm
  mov edx, eax
  and edx, 1
  shl edx, 2
  and eax, $FFFFFFFC
  mov eax, [eax+edx+4]
end;
{$ENDIF}
{--------}
{-Converts a parent node and child relationship into a cursor}
function Csr(P : PNode; C : TChild) : TTreeCursor;
{$IFDEF Windows}
inline($58/            {pop ax      get child}
       $25/$01/$00/    {and ax, 1   isolate child bit}
       $5B/            {pop bx      get offset}
       $09/$D8/        {or ax, bx   xfer child bit}
       $5A);           {pop dx      get seg/sel}
{$ELSE}
begin
  Result := TTreeCursor(longint(P) or Ord(C))
end;
{$ENDIF}
{--------}
{-Sets the cursor's color bit to zero}
function Bleach(Cursor : TTreeCursor) : TTreeCursor;
{$IFDEF Windows}
inline ($58/           {pop ax      get offset}
        $25/$FD/$FF/   {and ax, XX  set off color bit}
        $5A);          {pop dx      get seg/sel}
{$ELSE}
begin
  Result := (Cursor and $FFFFFFFD);
end;
{$ENDIF}
{--------}
{-Sets the cursor's color bit to the same as a PKC link}
function Dye(Cursor, PKC : TTreeCursor) : TTreeCursor;
{$IFDEF Windows}
inline ($58/             {pop ax      get color word}
        $25/$02/$00/     {and ax, 2   isolate color bit}
        $5B/             {pop bx      toss next}
        $5B/             {pop bx      get offset}
        $81/$E3/$FD/$FF/ {and bx, XX  kill color}
        $09/$D8/         {or ax, bx   xfer color bit}
        $5A);            {pop dx      get seg/sel}
{$ELSE}
begin
  Result := (Cursor and longint($FFFFFFFD)) or (PKC and $2);   {!!.02}
end;
{$ENDIF}

{===TBinTree==========================================================
A simple binary tree.

A binary tree is a data structure where each node has up to two
children, and one parent. This implementation makes a distinction
between external nodes (that have no children at all) and internal
nodes (that always have two children). External nodes are called
leaves. The object uses external cursors to navigate the tree (these
are NOT the nodes themselves). You position a given cursor in the tree
by moving it with the object's methods, and can use a cursor to insert
and delete data objects in the tree (although there are restrictions
on where this can happen).

The object has two iterators, and four methods to traverse the tree
with them. The four traversal methods are pre-order, in-order,
post-order and level-order. Note that traversals can be done either by
recursive routines or a TStack will be used to unravel the recursion.
This choice is set via the UseRecursion property.
=====================================================================}
constructor TBinTree.Create(DataOwner : boolean);
begin
  acNodeSize := 16;
  inherited Create(DataOwner);

  btTravType := ttInOrder;
  btUseRecursion := true;

  btRt := acNewNode(nil);
  acCount := 0;
end;
{--------}
constructor TBinTree.Clone(Source : TAbstractContainer;
                           DataOwner : boolean;
                           NewCompare : TCompareFunc);
var
  OldTree : TBinTree absolute Source;
  NewData : pointer;
  {------}
  procedure CloneTreeRecurse(OldWalker, NewWalker : TTreeCursor);
  var
    Temp, NewTemp : TTreeCursor;
  begin
    NewData := nil;
    try
      Temp := OldTree.Left(OldWalker);
      if not OldTree.IsLeaf(Temp) then begin
        if DataOwner then
          NewData := DupData(OldTree.Examine(Temp))
        else
          NewData := OldTree.Examine(Temp);
        NewTemp := Left(NewWalker);
        Insert(NewTemp, NewData);
        NewData := nil;
        CloneTreeRecurse(Temp, NewTemp);
      end;
      Temp := OldTree.Right(OldWalker);
      if not OldTree.IsLeaf(Temp) then begin
        if DataOwner then
          NewData := DupData(OldTree.Examine(Temp))
        else
          NewData := OldTree.Examine(Temp);
        NewTemp := Right(NewWalker);
        Insert(NewTemp, NewData);
        NewData := nil;
        CloneTreeRecurse(Temp, NewTemp);
      end;
    finally
      if DataOwner and Assigned(NewData) then
        DisposeData(NewData);
    end;{try..finally}
  end;
  {------}
  procedure CloneTreeNoRecurse;
  var
    StackOld, StackNew : TStack;
    OldWalker, NewWalker : TTreeCursor;
    Temp, NewTemp : TTreeCursor;
  begin
    StackOld := nil;
    StackNew := nil;
    NewData := nil;
    try
      StackOld := TStack.Create(false);
      StackNew := TStack.Create(false);
      if DataOwner then
        NewData := DupData(OldTree.Examine(OldTree.Root))
      else
        NewData := OldTree.Examine(OldTree.Root);
      NewTemp := Root;
      Insert(NewTemp, NewData);
      NewData := nil;
      StackOld.Push(pointer(OldTree.Root));
      StackNew.Push(pointer(Root));
      repeat
        OldWalker := TTreeCursor(StackOld.Pop);
        NewWalker := TTreeCursor(StackNew.Pop);
        Temp := OldTree.Left(OldWalker);
        if not OldTree.IsLeaf(Temp) then begin
          if DataOwner then
            NewData := DupData(OldTree.Examine(Temp))
          else
            NewData := OldTree.Examine(Temp);
          NewTemp := Left(NewWalker);
          Insert(NewTemp, NewData);
          NewData := nil;
          StackOld.Push(pointer(Temp));
          StackNew.Push(pointer(NewTemp));
        end;
        Temp := OldTree.Right(OldWalker);
        if not OldTree.IsLeaf(Temp) then begin
          if DataOwner then
            NewData := DupData(OldTree.Examine(Temp))
          else
            NewData := OldTree.Examine(Temp);
          NewTemp := Right(NewWalker);
          Insert(NewTemp, NewData);
          NewData := nil;
          StackOld.Push(pointer(Temp));
          StackNew.Push(pointer(NewTemp));
        end;
      until StackOld.IsEmpty;
    finally
      StackOld.Free;
      StackNew.Free;
      if DataOwner and Assigned(NewData) then
        DisposeData(NewData);
    end;{try..finally}
  end;
  {------}
var
  NewTemp : TTreeCursor;
begin
  Create(DataOwner);
  Compare := NewCompare;
  DupData := OldTree.DupData;
  DisposeData := OldTree.DisposeData;

  if not (Source is TBinTree) then
    RaiseError(escBadSource);

  if OldTree.IsEmpty then Exit;

  try
    NewData := nil;
    if UseRecursion then begin
      if DataOwner then
        NewData := DupData(OldTree.Examine(OldTree.Root))
      else
        NewData := OldTree.Examine(OldTree.Root);
      NewTemp := Root;
      Insert(NewTemp, NewData);
      NewData := nil;
      CloneTreeRecurse(OldTree.Root, Root);
    end
    else
      CloneTreeNoRecurse;
  except
    if DataOwner and Assigned(NewData) then
      DisposeData(NewData);
    raise;
  end;{try..except}
end;
{--------}
procedure TBinTree.btInsertPrim(var Cursor : TTreeCursor; aNode : PNode);
begin
  aNode^.PKC := Cursor;
  Dad(Cursor)^.TLink[Kid(Cursor)] := aNode;
end;
{--------}
function TBinTree.Delete(Cursor : TTreeCursor) : TTreeCursor;
var
  NewKid,
  LeftKid,
  RightKid : TTreeCursor;
  NodeToGo,
  Node : PNode;
begin
  if IsLeaf(Cursor) then
    RaiseError(escDelInvalidHere);
  RightKid := Right(Cursor);
  LeftKid := Left(Cursor);
  if not IsLeaf(RightKid) then begin
    if not IsLeaf(LeftKid) then
      RaiseError(escDelInvalidHere);
    NewKid := RightKid
  end
  else
    NewKid := LeftKid;
  Result := Cursor;
  Node := GetNode(NewKid);
  NodeToGo := GetNode(Cursor);
  Dad(Cursor)^.TLink[Kid(Cursor)] := Node;
  if not IsLeaf(NewKid) then
    with Node^ do
      PKC := Dye(Cursor, PKC);
  acDisposeNode(NodeToGo);
end;
{--------}
procedure TBinTree.Empty;
  {------}
  procedure RecursePostOrder(Cursor : TTreeCursor);
  begin
    if not IsLeaf(Cursor) then begin
      RecursePostOrder(Left(Cursor));
      RecursePostOrder(Right(Cursor));
      if IsDataOwner then
        DisposeData(Examine(Cursor));
      acDisposeNode(GetNode(Cursor));
    end;
  end;
  {------}
const
  Sentinel = nil;
var
  Walker : PNode;
  Stack  : TStack;
begin
  if UseRecursion then begin
    if not IsEmpty then begin
      RecursePostOrder(Root);
      btRt^.TLink[CRight] := nil;
    end;
  end
  else {no recursion} begin
    if not IsEmpty then begin
      Stack := TStack.Create(false);
      try
        Stack.Push(btRt^.TLink[cRight]);
        repeat
          Walker := PNode(Stack.Examine);
          if (Walker = Sentinel) then begin
            Stack.Pop; {the sentinel}
            Walker := PNode(Stack.Pop);
            if IsDataOwner then
              DisposeData(Walker^.Data);
            acDisposeNode(Walker);