jclbinarytrees.pas

East make Tray Icon in delphi

    while (FCursor <> nil) and (FCursor.Right = FLastRet) do
    begin
      FLastRet := FCursor;
      FCursor := FCursor.Parent;
    end;
  end;
end;

function TInOrderItr.Previous: TObject;
{$IFDEF THREADSAFE}
var
  CS: IInterface;
{$ENDIF THREADSAFE}
begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  Result := FCursor.Obj;
  FLastRet := FCursor;
  if FCursor.Left <> nil then
  begin
    FCursor := FCursor.Left;
    while FCursor.Right <> nil do
    begin
      FLastRet := FCursor;
      FCursor := FCursor.Right;
    end;
  end
  else
  begin
    FCursor := FCursor.Parent;
    while (FCursor <> nil) and (FCursor.Right <> FLastRet) do // Come from Left
    begin
      FLastRet := FCursor;
      FCursor := FCursor.Parent;
    end;
  end;
end;

//=== { TPostOrderItr } ======================================================

type
  TPostOrderItr = class(TItr, IJclIterator)
  protected
    { IJclIterator }
    function Next: TObject; override;
    function Previous: TObject; override;
  end;

function TPostOrderItr.Next: TObject;
{$IFDEF THREADSAFE}
var
  CS: IInterface;
{$ENDIF THREADSAFE}
begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  if (FCursor.Left <> FLastRet) and (FCursor.Right <> FLastRet) then
    while FCursor.Left <> nil do
      FCursor := FCursor.Left;
  if (FCursor.Right <> nil) and (FCursor.Right <> FLastRet) then
  begin
    FCursor := FCursor.Right;
    while FCursor.Left <> nil do
      FCursor := FCursor.Left;
    if FCursor.Right <> nil then // particular worst case
      FCursor := FCursor.Right;
  end;
  Result := FCursor.Obj;
  FLastRet := FCursor;
  FCursor := FCursor.Parent;
end;

function TPostOrderItr.Previous: TObject;
{$IFDEF THREADSAFE}
var
  CS: IInterface;
{$ENDIF THREADSAFE}
begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  Result := FCursor.Obj;
  FLastRet := FCursor;
  if (FCursor.Right <> nil) and (FCursor.Right <> FLastRet) then
    FCursor := FCursor.Right
  else
  begin
    FCursor := FCursor.Parent;
    while (FCursor <> nil) and ((FCursor.Left = nil) or (FCursor.Left = FLastRet)) do
    begin
      FLastRet := FCursor;
      FCursor := FCursor.Parent;
    end;
    if FCursor <> nil then // not root
      FCursor := FCursor.Left;
  end;
end;

//=== { TJclIntfBinaryTree } =================================================

constructor TJclIntfBinaryTree.Create(AComparator: TIntfCompare = nil);
begin
  inherited Create;
  if Assigned(AComparator) then
    FComparator := AComparator
  else
    FComparator := @IntfSimpleCompare;
  FTraverseOrder := toPreOrder;
end;

destructor TJclIntfBinaryTree.Destroy;
begin
  Clear;
  inherited Destroy;
end;

function TJclIntfBinaryTree.Add(AInterface: IInterface): Boolean;
var
  NewNode: PJclIntfBinaryNode;
  Current, Save: PJclIntfBinaryNode;
  {$IFDEF THREADSAFE}
  CS: IInterface;
  {$ENDIF THREADSAFE}
begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  Result := False;
  if AInterface = nil then
    Exit;
  NewNode := AllocMem(SizeOf(TJclIntfBinaryNode));
  NewNode^.Obj := AInterface;
  // Insert into right place
  Save := nil;
  Current := FRoot;
  while Current <> nil do
  begin
    Save := Current;
    if FComparator(NewNode^.Obj, Current.Obj) < 0 then
      Current := Current.Left
    else
      Current := Current.Right;
  end;
  NewNode^.Parent := Save;
  if Save = nil then
    FRoot := NewNode
  else
  if FComparator(NewNode^.Obj, Save.Obj) < 0 then
    Save.Left := NewNode
  else
    Save.Right := NewNode;
  // RB balanced
  NewNode^.Color := tcRed;
  while (NewNode <> FRoot) and (NewNode^.Parent^.Color = tcRed) do
  begin
    if (NewNode^.Parent^.Parent <> nil) and (NewNode^.Parent = NewNode^.Parent^.Parent^.Left) then
    begin
      Current := NewNode^.Parent^.Parent^.Right;
      if Current.Color = tcRed then
      begin
        NewNode^.Parent^.Color := tcBlack;
        Current.Color := tcBlack;
        NewNode^.Parent^.Parent^.Color := tcRed;
        NewNode := NewNode^.Parent^.Parent;
      end
      else
      begin
        if NewNode = NewNode^.Parent^.Right then
        begin
          NewNode := NewNode^.Parent;
          RotateLeft(NewNode);
        end;
        NewNode^.Parent^.Color := tcBlack;
        NewNode^.Parent^.Parent^.Color := tcRed;
        RotateRight(NewNode^.Parent^.Parent);
      end;
    end
    else
    begin
      if NewNode^.Parent^.Parent = nil then
        Current := nil
      else
        Current := NewNode^.Parent^.Parent^.Left;
      if (Current <> nil) and (Current.Color = tcRed) then
      begin
        NewNode^.Parent^.Color := tcBlack;
        Current.Color := tcBlack;
        NewNode^.Parent^.Parent^.Color := tcRed;
        NewNode := NewNode^.Parent^.Parent;
      end
      else
      begin
        if NewNode = NewNode^.Parent^.Left then
        begin
          NewNode := NewNode^.Parent;
          RotateRight(NewNode);
        end;
        NewNode^.Parent^.Color := tcBlack;
        if NewNode^.Parent^.Parent <> nil then
          NewNode^.Parent^.Parent^.Color := tcRed;
        RotateLeft(NewNode^.Parent^.Parent);
      end;
    end;
  end;
  FRoot.Color := tcBlack;
  Inc(FCount);
  Result := True;
end;

function TJclIntfBinaryTree.AddAll(ACollection: IJclIntfCollection): Boolean;
var
  It: IJclIntfIterator;
  {$IFDEF THREADSAFE}
  CS: IInterface;
  {$ENDIF THREADSAFE}
begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  Result := False;
  if ACollection = nil then
    Exit;
  It := ACollection.First;
  while It.HasNext do
    Result := Add(It.Next) or Result;
end;

procedure TJclIntfBinaryTree.Clear;
{$IFDEF THREADSAFE}
var
  CS: IInterface;
{$ENDIF THREADSAFE}

{$IFDEF RECURSIVE}
  procedure FreeChild(Node: PJclIntfBinaryNode);
  begin
    if Node^.Left <> nil then
      FreeChild(Node^.Left);
    if Node^.Right <> nil then
      FreeChild(Node^.Right);
    Node^.Obj := nil; // Force Release
    FreeMem(Node);
  end;
{$ELSE}
var
  Current: PJclIntfBinaryNode;
  Save: PJclIntfBinaryNode;
{$ENDIF RECURSIVE}

begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  {$IFDEF RECURSIVE}
  // recursive version
  if FRoot <> nil then
  begin
    FreeChild(FRoot);
    FRoot := nil;
  end;
  {$ELSE}
  // iterative version
  Current := FRoot;
  while Current <> nil do
  begin
    if Current.Left <> nil then
      Current := Current.Left
    else
    if Current.Right <> nil then
      Current := Current.Right
    else
    begin
      Current.Obj := nil; // Force Release
      if Current.Parent = nil then // Root
      begin
        FreeMem(Current);
        Current := nil;
        FRoot := nil;
      end
      else
      begin
        Save := Current;
        Current := Current.Parent;
        if Save = Current.Right then // True = from Right
        begin
          FreeMem(Save);
          Current.Right := nil;
        end
        else
        begin
          FreeMem(Save);
          Current.Left := nil;
        end
      end;
    end;
  end;
  {$ENDIF RECURSIVE}
  FCount := 0;
end;

function TJclIntfBinaryTree.Clone: IInterface;
var
  NewTree: TJclIntfBinaryTree;

  function CloneNode(Node, Parent: PJclIntfBinaryNode): PJclIntfBinaryNode;
  begin
    if Node <> nil then
    begin
      GetMem(Result, SizeOf(TJclIntfBinaryNode));
      Result.Obj := Node^.Obj;
      Result.Color := Node^.Color;
      Result.Parent := Parent;
      Result.Left := CloneNode(Node^.Left, Result); // recursive call
      Result.Right := CloneNode(Node^.Right, Result); // recursive call
    end
    else
      Result := nil;
  end;

begin
  NewTree := TJclIntfBinaryTree.Create(FComparator);
  NewTree.FCount := FCount;
  NewTree.FRoot := CloneNode(FRoot, nil);
  Result := NewTree;
end;

function TJclIntfBinaryTree.Contains(AInterface: IInterface): Boolean;
var
  {$IFDEF THREADSAFE}
  CS: IInterface;
  {$ENDIF THREADSAFE}
  Comp: Integer;

{$IFDEF RECURSIVE}
  function ContainsChild(Node: PJclIntfBinaryNode): Boolean;
  begin
    Result := False;
    if Node = nil then
      Exit;
    Comp := FComparator(Node^.Obj, AInterface);
    if Comp = 0 then
      Result := True
    else
    if Comp > 0 then
      Result := ContainsChild(Node^.Left)
    else
      Result := ContainsChild(Node^.Right);
  end;
{$ELSE}
var
  Current: PJclIntfBinaryNode;
{$ENDIF RECURSIVE}

begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  Result := False;
  if AInterface = nil then
    Exit;
  {$IFDEF RECURSIVE}
  // recursive version
  Result := ContainsChild(FRoot);
  {$ELSE}
  // iterative version
  Current := FRoot;
  while Current <> nil do
  begin
    Comp := FComparator(Current.Obj, AInterface);
    if Comp = 0 then
    begin
      Result := True;
      Break;
    end
    else
    if Comp > 0 then
      Current := Current.Left
    else
      Current := Current.Right;
  end;
  {$ENDIF RECURSIVE}
end;

function TJclIntfBinaryTree.ContainsAll(ACollection: IJclIntfCollection): Boolean;
var
  It: IJclIntfIterator;
  {$IFDEF THREADSAFE}
  CS: IInterface;
  {$ENDIF THREADSAFE}
begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  Result := True;
  if ACollection = nil then
    Exit;
  It := ACollection.First;
  while Result and It.HasNext do
    Result := Contains(It.Next);
end;

function TJclIntfBinaryTree.Equals(ACollection: IJclIntfCollection): Boolean;
var
  It, ItSelf: IJclIntfIterator;
  {$IFDEF THREADSAFE}
  CS: IInterface;
  {$ENDIF THREADSAFE}
begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  Result := False;
  if ACollection = nil then
    Exit;
  if FCount <> ACollection.Size then
    Exit;
  It := ACollection.First;
  ItSelf := First;
  while ItSelf.HasNext do
    if FComparator(ItSelf.Next, It.Next) <> 0 then
      Exit;
  Result := True;
end;

function TJclIntfBinaryTree.First: IJclIntfIterator;
begin
  case GetTraverseOrder of
    toPreOrder:
      Result := TPreOrderIntfItr.Create(Self, FRoot);
    toOrder:
      Result := TInOrderIntfItr.Create(Self, FRoot);
    toPostOrder:
      Result := TPostOrderIntfItr.Create(Self, FRoot);
  end;
end;

function TJclIntfBinaryTree.GetTraverseOrder: TJclTraverseOrder;
begin
  Result := FTraverseOrder;
end;

function TJclIntfBinaryTree.IsEmpty: Boolean;
begin
  Result := FCount = 0;
end;

function TJclIntfBinaryTree.Last: IJclIntfIterator;
var
  Start: PJclIntfBinaryNode;
begin
  Start := FRoot;
  case FTraverseOrder of
    toPreOrder:
      begin
        if Start <> nil then
          while Start.Right <> nil do
            Start := Start.Right;
        Result := TPreOrderIntfItr.Create(Self, Start);
      end;
    toOrder:
      begin
        if Start <> nil then
          while Start.Right <> nil do
            Start := Start.Right;
        Result := TInOrderIntfItr.Create(Self, Start);
      end;
    toPostOrder:
      Result := TPostOrderIntfItr.Create(Self, Start);
  end;
end;

procedure TJclIntfBinaryTree.RotateLeft(Node: PJclIntfBinaryNode);
var
  TempNode: PJclIntfBinaryNode;
begin
  if Node = nil then
    Exit;
  TempNode := Node^.Right;
  //  if TempNode = nil then	Exit;
  Node^.Right := TempNode^.Left;
  if TempNode^.Left <> nil then
    TempNode^.Left^.Parent := Node;
  TempNode^.Parent := Node^.Parent;
  if Node^.Parent = nil then
    FRoot := TempNode
  else
  if Node^.Parent^.Left = Node then
    Node^.Parent^.Left := TempNode
  else
    Node^.Parent^.Right := TempNode;
  TempNode^.Left := Node;
  Node^.Parent := TempNode;
end;

procedure TJclIntfBinaryTree.RotateRight(Node: PJclIntfBinaryNode);
var
  TempNode: PJclIntfBinaryNode;
begin
  if Node = nil then
    Exit;
  TempNode := Node^.Left;
  //  if TempNode = nil then 	Exit;
  Node^.Left := TempNode^.Right;
  if TempNode^.Right <> nil then
    TempNode^.Right^.Parent := Node;
  TempNode^.Parent := Node^.Parent;
  if Node^.Parent = nil then
    FRoot := TempNode
  else
  if Node^.Parent^.Right = Node then
    Node^.Parent^.Right := TempNode
  else