ezdslbtr.pas

Eazy Data Structures library for Delphi.

  end;{try..finally}
end;
{--------}
procedure TBinSearchTree.acSort;
var
  OldRoot : PNode;
begin
  {Note: when this routine is called, the Compare method will have
         been replaced, and we have to 'sort' the tree}
  {detach the old tree from the object}
  OldRoot := btRt;
  {create a new root}
  btRt := acNewNode(nil);
  btRt^.TLink[CLeft] := btRt;
  btRt^.TLink[CRight] := nil;
  acCount := 0;
  {traverse the old tree and append the data to the new root}
  bsSortTraverse(OldRoot^.TLink[CRight]);
  {destroy the old root (increment the count afterwards, since the
   dispose-a-node routine will decrement it)}
  acDisposeNode(OldRoot);
  inc(acCount);
end;
{--------}
procedure TBinSearchTree.bsSortTraverse(aNode : PNode);
const
  Sentinel = nil;
var
  Walker : PNode;
  Stack  : TStack;
  Cursor : TTreeCursor;
begin
  if UseRecursion then begin
    if (aNode <> nil) then begin
      {traverse the left subtree}
      bsSortTraverse(aNode^.TLink[cLeft]);
      {traverse the right subtree}
      bsSortTraverse(aNode^.TLink[cRight]);
      {pretend we've just created this node and insert it}
      if Search(Cursor, aNode^.Data) then
        RaiseError(escInsertDup);
      inc(acCount);
      aNode^.TLink[cLeft] := nil;
      aNode^.TLink[cRight] := nil;
      btInsertPrim(Cursor, aNode);
    end;
  end
  else {no recursion} begin
    Stack := TStack.Create(false);
    try
      Stack.Push(aNode);
      repeat
        Walker := PNode(Stack.Examine);
        if (Walker = Sentinel) then begin
          Stack.Pop; {the sentinel}
          Walker := PNode(Stack.Pop); {the node}
          {pretend we've just created this node and insert it}
          if Search(Cursor, Walker^.Data) then
            RaiseError(escInsertDup);
          inc(acCount);
          Walker^.TLink[cLeft] := nil;
          Walker^.TLink[cRight] := nil;
          btInsertPrim(Cursor, Walker);
        end
        else begin
          Stack.Push(Sentinel);
          if (Walker^.TLink[cRight] <> nil) then
            Stack.Push(Walker^.TLink[cRight]);
          if (Walker^.TLink[cLeft] <> nil) then
            Stack.Push(Walker^.TLink[cLeft]);
        end;
      until (Stack.IsEmpty);
    finally
      Stack.Free;
    end;{try..finally}
  end;
end;
{--------}
procedure TBinSearchTree.bsSwapData(OldCursor, NewCursor : TTreeCursor);
var
  Data : pointer;
begin
  Data := GetNode(OldCursor)^.Data;
  GetNode(OldCursor)^.Data := GetNode(NewCursor)^.Data;
  GetNode(NewCursor)^.Data := Data;
end;
{--------}
function TBinSearchTree.Delete (Cursor : TTreeCursor) : TTreeCursor;
var
  Walker,
  LeftChild : TTreeCursor;
begin
  if IsLeaf(Cursor) then
    RaiseError(escDelInvalidHere);
  if IsLeaf(Left(Cursor)) or IsLeaf(Right(Cursor)) then
    Result := inherited Delete(Cursor)
  else {both children exist} begin
    Walker := Right(Cursor);
    LeftChild := Left(Walker);
    while not IsLeaf(LeftChild) do begin
      Walker := LeftChild;
      LeftChild := Left(Walker);
    end;
    bsSwapData(Cursor, Walker);
    Result := inherited Delete(Walker);
  end;
end;
{--------}
procedure TBinSearchTree.Insert(var Cursor : TTreeCursor; aData : pointer);
begin
  if Search(Cursor, aData) then
    RaiseError(escInsertDup);
  inherited Insert(Cursor, aData);
end;
{--------}
procedure TBinSearchTree.Join(Cursor : TTreeCursor; Tree : TBinTree);
begin
  if Assigned(Tree) then
    with Tree do begin
      TraversalType := ttPostOrder;
      Iterate(BSTreeJoinData, false, Self);
      acIsDataOwner := false;
      Free;
    end;
end;
{--------}
function TBinSearchTree.Replace(Cursor : TTreeCursor; aData : pointer) : pointer;
begin
  Result := Examine(Cursor);
  Delete(Cursor);
  Insert(Cursor, aData);
end;
{--------}
function TBinSearchTree.Search(var Cursor : TTreeCursor; aData : pointer) : boolean;
var
  CompResult : integer;
  Walker     : TTreeCursor;
begin
  Walker := Root;
  if IsLeaf(Walker) then
    Result := false
  else begin
    CompResult := Compare(aData, Examine(Walker));
    if (CompResult < 0) then
      Walker := Left(Walker)
    else if (CompResult > 0) then
      Walker := Right(Walker);
    while (not IsLeaf(Walker)) and (CompResult <> 0) do begin
      CompResult := Compare(aData, Examine(Walker));
      if (CompResult < 0) then
        Walker := Left(Walker)
      else if (CompResult > 0) then
        Walker := Right(Walker);
    end;
    Result := (CompResult = 0);
  end;
  Cursor := Walker;
end;
{====================================================================}

{$IFDEF Windows}
type
  LH = record L, H : word; end;
{$ENDIF}

{===Red-black tree helper routines====================================
These routines help out the red-black tree methods. ColorBlack colors
the cursor black, ColorRed colors the cursor red. IsBlack returns true
if the cursor is black, whereas IsRed returns true if is red.
18Jun95 JMB
=====================================================================}
procedure ColorBlack(Cursor : TTreeCursor);
{$IFDEF Windows}
near;
begin
  with GetNode(Cursor)^ do
    LH(PKC).L := LH(PKC).L and $FFFD;
end;
{$ELSE}
begin
  with GetNode(Cursor)^ do
    PKC := PKC and $FFFFFFFD;
end;
{$ENDIF}
{--------}
function IsBlack(Cursor : TTreeCursor) : boolean;
{$IFDEF Windows}
near;
var
  Temp : PNode;
begin
  Temp := GetNode(Cursor);
  if Assigned(Temp) then
    IsBlack := (LH(Temp^.PKC).L and 2) = 0
  else
    IsBlack := true;
end;
{$ELSE}
var
  Temp : PNode;
begin
  Temp := GetNode(Cursor);
  if Assigned(Temp) then
    IsBlack := (Temp^.PKC and 2) = 0
  else
    IsBlack := true;
end;
{$ENDIF}
{--------}
procedure ColorRed(Cursor : TTreeCursor);
{$IFDEF Windows}
near;
begin
  with GetNode(Cursor)^ do
    LH(PKC).L := LH(PKC).L or 2;
end;
{$ELSE}
begin
  with GetNode(Cursor)^ do
    PKC := PKC or 2;
end;
{$ENDIF}
{--------}
function IsRed(Cursor : TTreeCursor) : boolean;
{$IFDEF Windows}
near;
var
  Temp : PNode;
begin
  Temp := GetNode(Cursor);
  if Assigned(Temp) then
    IsRed := (LH(Temp^.PKC).L and 2) <> 0
  else
    IsRed := false;
end;
{$ELSE}
var
  Temp : PNode;
begin
  Temp := GetNode(Cursor);
  if Assigned(Temp) then
    IsRed := (Temp^.PKC and 2) <> 0
  else
    IsRed := false;
end;
{$ENDIF}

{===TrbSearchTree=====================================================
A red-black binary search tree

A red-black tree is a binary search tree with inbuilt balancing
algorithms during Insert and Delete. This ensures that the tree does
not degenerate into a sorted linked list, maintaining its excellent
search times.

The tree is called red-black because certain data objects are labelled
Black and the others Red such that (1) every Red data object (that is
not at the root) has a Black parent, (2) each path from leaf to root
has the same number of Black data objects, and (3) each leaf is Black.
This set of rules ensures that the tree is (quite) balanced.

References
  Sedgewick: Algorithms
  Wood: Data Structures, Algorithms, and Performance

PS. I also apologise for the unpolitically correct terminology in this
source code! Thank you, Bryan, for pointing it out, but it's too late
now...
=====================================================================}
procedure TrbSearchTree.bsSwapData(OldCursor, NewCursor : TTreeCursor);
begin
  rbDeletedNodeWasBlack := IsBlack(NewCursor);
  inherited bsSwapData(OldCursor, NewCursor);
end;
{--------}
procedure TrbSearchTree.btInsertPrim(var Cursor : TTreeCursor; aNode : PNode);
var
  Pa, GrandPa, Uncle : TTreeCursor;
  Balanced : boolean;
begin
  inherited btInsertPrim(Cursor, aNode);
  ColorRed(Cursor);
  repeat
    Balanced := true;
    if not IsRoot(Cursor) then begin
      Pa := Parent(Cursor);
      if IsRed(Pa) then begin
        if IsRoot(Pa) then
          ColorBlack(Pa)
        else {Pa is not a root} begin
          GrandPa := Parent(Pa);
          ColorRed(GrandPa);
          if (Kid(Pa) = CLeft) then
            Uncle := Right(GrandPa)
          else
            Uncle := Left(GrandPa);
          if IsRed(Uncle) then begin
            ColorBlack(Pa);
            ColorBlack(Uncle);
            Cursor := GrandPa;
            Balanced := false;
          end
          else {Uncle is black} begin
            if (Kid(Cursor) = Kid(Pa)) then begin
              ColorBlack(Pa);
              rbPromote(Pa); {discard result}
            end
            else begin
              ColorBlack(Cursor);
              Cursor := rbPromote(rbPromote(Cursor));
            end;
          end;
        end;
      end;
    end;
  until Balanced;
end;
{--------}
function TrbSearchTree.Delete(Cursor : TTreeCursor) : TTreeCursor;
var
  Pa, Brother, Nephew1, Nephew2 : TTreeCursor;
  Balanced : boolean;
begin
  rbDeletedNodeWasBlack := IsBlack(Cursor);
  Cursor := inherited Delete(Cursor);
  Result := Cursor;
  repeat
    Balanced := true;
    if rbDeletedNodeWasBlack then begin
      if IsRed(Cursor) then
        ColorBlack(Cursor)
      else if not IsRoot(Cursor) then begin
        Pa := Parent(Cursor);
        if (Kid(Cursor) = CLeft) then
          Brother := Right(Pa)
        else
          Brother := Left(Pa);
        if IsRed(Brother) then begin
          if IsBlack(Pa) then
            ColorBlack(Brother);
          ColorRed(Pa);
          Brother := rbPromote(Brother);
          if (Kid(Cursor) = CLeft) then
            Cursor := Left(Left(Brother))
          else
            Cursor := Right(Right(Brother));
          Balanced := false;
        end
        else {Brother is black} begin
          if (Kid(Cursor) = CLeft) then
            Nephew1 := Right(Brother)
          else
            Nephew1 := Left(Brother);
          if IsRed(Nephew1) then begin
            ColorBlack(Nephew1);
            if IsRed(Pa) then
              ColorRed(Brother);
            ColorBlack(Pa);
            rbPromote(Brother); {discard result}
          end
          else {Nephew1 is black} begin
            if (Kid(Cursor) = CLeft) then
              Nephew2 := Left(Brother)
            else
              Nephew2 := Right(Brother);
            if IsRed(Nephew2) then begin
              if IsBlack(Pa) then
                ColorBlack(Nephew2);
              ColorBlack(Pa);
              rbPromote(rbPromote(Nephew2)); {discard result}
            end
            else {Nephew2 is black} begin
              if IsRed(Pa) then begin
                ColorBlack(Pa);
                ColorRed(Brother);
              end
              else {Pa is black} begin
                ColorRed(Brother);
                Cursor := Pa;
                Balanced := false;
              end;
            end;
          end;
        end;
      end;
    end;
  until Balanced;
end;
{--------}
function TrbSearchTree.rbPromote(Cursor : TTreeCursor) : TTreeCursor;
var
  NodeX,
  NodeP,
  XSon  : PNode;
begin
  NodeX := GetNode(Cursor);
  NodeP := Dad(Cursor);

  with NodeP^ do begin
    Dad(PKC)^.TLink[Kid(PKC)] := NodeX;
    NodeX^.PKC := Dye(PKC, NodeX^.PKC);
  end;

  if (Kid(Cursor) = CLeft) then begin
    XSon := NodeX^.TLink[CRight];
    NodeX^.TLink[CRight] := NodeP;
    NodeP^.PKC := Dye(Csr(NodeX, CRight), NodeP^.PKC);
    NodeP^.TLink[CLeft] := XSon;
    if (XSon <> nil) then
      XSon^.PKC := Dye(Cursor, XSon^.PKC);
  end
  else begin
    XSon := NodeX^.TLink[CLeft];
    NodeX^.TLink[CLeft] := NodeP;
    NodeP^.PKC := Dye(Csr(NodeX, CLeft), NodeP^.PKC);
    NodeP^.TLink[CRight] := XSon;
    if (XSon <> nil) then
      XSon^.PKC := Dye(Cursor, XSon^.PKC);
  end;

  Result := Bleach(NodeX^.PKC);
end;
{====================================================================}


{$IFDEF ThreadsExist}
{===TThreadsafeBinTree===============================================}
constructor TThreadsafeBinTree.Create(aDataOwner : boolean);
begin
  inherited Create;
  btResLock := TezResourceLock.Create;
  btBinTree := TBinTree.Create(aDataOwner);
end;
{--------}
destructor TThreadsafeBinTree.Destroy;
begin
  btBinTree.Free;
  btResLock.Free;
  inherited Destroy;
end;
{--------}
function TThreadsafeBinTree.AcquireAccess : TBinTree;
begin
  btResLock.Lock;
  Result := btBinTree;
end;
{--------}
procedure TThreadsafeBinTree.ReleaseAccess;
begin
  btResLock.Unlock;
end;
{====================================================================}
{$ENDIF}


{$IFDEF ThreadsExist}
{===TThreadsafeBinSearchTree=========================================}
constructor TThreadsafeBinSearchTree.Create(aDataOwner : boolean);
begin
  inherited Create;
  bstResLock := TezResourceLock.Create;
  bstBinSearchTree := TBinSearchTree.Create(aDataOwner);
end;
{--------}
destructor TThreadsafeBinSearchTree.Destroy;
begin
  bstBinSearchTree.Free;
  bstResLock.Free;
  inherited Destroy;
end;
{--------}
function TThreadsafeBinSearchTree.AcquireAccess : TBinSearchTree;
begin
  bstResLock.Lock;
  Result := bstBinSearchTree;
end;
{--------}
procedure TThreadsafeBinSearchTree.ReleaseAccess;
begin
  bstResLock.Unlock;
end;
{====================================================================}
{$ENDIF}


{$IFDEF ThreadsExist}
{===TThreadsaferbSearchTree==========================================}
constructor TThreadsaferbSearchTree.Create(aDataOwner : boolean);
begin
  inherited Create;
  rbstResLock := TezResourceLock.Create;
  rbstrbSearchTree := TrbSearchTree.Create(aDataOwner);
end;
{--------}
destructor TThreadsaferbSearchTree.Destroy;
begin
  rbstrbSearchTree.Free;
  rbstResLock.Free;
  inherited Destroy;
end;
{--------}
function TThreadsaferbSearchTree.AcquireAccess : TrbSearchTree;
begin
  rbstResLock.Lock;
  Result := rbstrbSearchTree;
end;
{--------}
procedure TThreadsaferbSearchTree.ReleaseAccess;
begin
  rbstResLock.Unlock;
end;
{====================================================================}
{$ENDIF}

end.