jclbinarytrees.pas

East make Tray Icon in delphi

    Node^.Parent^.Left := TempNode;
  TempNode^.Right := Node;
  Node^.Parent := TempNode;
end;

function TJclIntfBinaryTree.Remove(AInterface: IInterface): Boolean;
var
  Current: PJclIntfBinaryNode;
  Node: PJclIntfBinaryNode;
  Save: PJclIntfBinaryNode;
  Comp: Integer;
  {$IFDEF THREADSAFE}
  CS: IInterface;
  {$ENDIF THREADSAFE}

  procedure Correction(Node: PJclIntfBinaryNode);
  var
    TempNode: PJclIntfBinaryNode;
  begin
    while (Node <> FRoot) and (Node^.Color = tcBlack) do
    begin
      if Node = Node^.Parent^.Left then
      begin
        TempNode := Node^.Parent^.Right;
        if TempNode = nil then
        begin
          Node := Node^.Parent;
          Continue;
        end;
        if TempNode^.Color = tcRed then
        begin
          TempNode^.Color := tcBlack;
          Node^.Parent^.Color := tcRed;
          RotateLeft(Node^.Parent);
          TempNode := Node^.Parent^.Right;
        end;
        if (TempNode^.Left <> nil) and (TempNode^.Left^.Color = tcBlack) and
          (TempNode^.Right <> nil) and (TempNode^.Right^.Color = tcBlack) then
        begin
          TempNode^.Color := tcRed;
          Node := Node^.Parent;
        end
        else
        begin
          if (TempNode^.Right <> nil) and (TempNode^.Right^.Color = tcBlack) then
          begin
            TempNode^.Left^.Color := tcBlack;
            TempNode^.Color := tcRed;
            RotateRight(TempNode);
            TempNode := Node^.Parent^.Right;
          end;
          TempNode^.Color := Node^.Parent^.Color;
          Node^.Parent^.Color := tcBlack;
          if TempNode^.Right <> nil then
            TempNode^.Right^.Color := tcBlack;
          RotateLeft(Node^.Parent);
          Node := FRoot;
        end;
      end
      else
      begin
        TempNode := Node^.Parent^.Left;
        if TempNode = nil then
        begin
          Node := Node^.Parent;
          Continue;
        end;
        if TempNode^.Color = tcRed then
        begin
          TempNode^.Color := tcBlack;
          Node^.Parent^.Color := tcRed;
          RotateRight(Node^.Parent);
          TempNode := Node^.Parent^.Left;
        end;
        if (TempNode^.Left^.Color = tcBlack) and (TempNode^.Right^.Color = tcBlack) then
        begin
          TempNode^.Color := tcRed;
          Node := Node^.Parent;
        end
        else
        begin
          if TempNode^.Left^.Color = tcBlack then
          begin
            TempNode^.Right^.Color := tcBlack;
            TempNode^.Color := tcRed;
            RotateLeft(TempNode);
            TempNode := Node^.Parent^.Left;
          end;
          TempNode^.Color := Node^.Parent^.Color;
          Node^.Parent^.Color := tcBlack;
          if TempNode^.Left <> nil then
            TempNode^.Left^.Color := tcBlack;
          RotateRight(Node^.Parent);
          Node := FRoot;
        end;
      end;
    end;
    Node^.Color := tcBlack;
  end;

begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  Result := False;
  if AInterface = nil then
    Exit;
  // locate AInterface in the tree
  Current := FRoot;
  while Current <> nil do
  begin
    Comp := FComparator(AInterface, Current.Obj);
    if Comp = 0 then
      Break
    else
    if Comp < 0 then
      Current := Current.Left
    else
      Current := Current.Right;
  end;
  if Current = nil then
    Exit;
  // Remove
  if (Current.Left = nil) or (Current.Right = nil) then
    Save := Current
  else
  begin // Successor in Save
    if Current.Right <> nil then
    begin
      Save := Current.Right;
      while Save.Left <> nil do // Minimum
        Save := Save.Left;
    end
    else
    begin
      Save := Current.Parent;
      while (Save <> nil) and (Current = Save.Right) do
      begin
        Current := Save;
        Save := Save.Parent;
      end;
    end;
  end;
  if Save.Left <> nil then
    Node := Save.Left
  else
    Node := Save.Right;
  if Node <> nil then
  begin
    Node^.Parent := Save.Parent;
    if Save.Parent = nil then
      FRoot := Node
    else
    if Save = Save.Parent^.Left then
      Save.Parent^.Left := Node
    else
      Save.Parent^.Right := Node;
    if Save.Color = tcBlack then
      Correction(Node);
  end
  else
  if Save.Parent = nil then
    FRoot := nil
  else
  begin
    if Save.Color = tcBlack then
      Correction(Save);
    if Save.Parent <> nil then
      if Save = Save.Parent^.Left then
        Save.Parent^.Left := nil
      else
      if Save = Save.Parent^.Right then
        Save.Parent^.Right := nil
  end;
  FreeMem(Save);
  Dec(FCount);
end;

function TJclIntfBinaryTree.RemoveAll(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 It.HasNext do
    Result := Remove(It.Next) and Result;
end;

function TJclIntfBinaryTree.RetainAll(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 := First;
  while It.HasNext do
    if not ACollection.Contains(It.Next) then
      It.Remove;
end;

procedure TJclIntfBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);
begin
  FTraverseOrder := Value;
end;

function TJclIntfBinaryTree.Size: Integer;
begin
  Result := FCount;
end;

//=== { TJclStrBinaryTree } ==================================================

constructor TJclStrBinaryTree.Create(AComparator: TStrCompare = nil);
begin
  inherited Create;
  if Assigned(AComparator) then
    FComparator := AComparator
  else
    FComparator := @StrSimpleCompare;
  FTraverseOrder := toPreOrder;
end;

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

function TJclStrBinaryTree.Add(const AString: string): Boolean;
var
  NewNode: PJclStrBinaryNode;
  Current, Save: PJclStrBinaryNode;
  {$IFDEF THREADSAFE}
  CS: IInterface;
  {$ENDIF THREADSAFE}
begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  Result := False;
  if AString = '' then
    Exit;
  NewNode := AllocMem(SizeOf(TJclStrBinaryNode));
  NewNode^.Str := AString;
  // Insert into right place
  Save := nil;
  Current := FRoot;
  while Current <> nil do
  begin
    Save := Current;
    if FComparator(NewNode^.Str, Current.Str) < 0 then
      Current := Current.Left
    else
      Current := Current.Right;
  end;
  NewNode^.Parent := Save;
  if Save = nil then
    FRoot := NewNode
  else
  if FComparator(NewNode^.Str, Save.Str) < 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 <> 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^.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 TJclStrBinaryTree.AddAll(ACollection: IJclStrCollection): Boolean;
var
  It: IJclStrIterator;
  {$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;
{

function TJclStrBinaryTree.GetAsStrings: TStrings;
begin
  Result := TStringList.Create;
  try
    AppendToStrings(Result);
  except
    Result.Free;
    raise;
  end;
end;

procedure TJclStrBinaryTree.LoadFromStrings(Strings: TStrings);
begin
  Clear;
  AppendFromStrings(Strings);
end;

procedure TJclStrBinaryTree.AppendToStrings(Strings: TStrings);
var
  It: IJclStrIterator;
begin
  It := First;
  Strings.BeginUpdate;
  try
    while It.HasNext do
      Strings.Add(It.Next);
  finally
    Strings.EndUpdate;
  end;
end;

procedure TJclStrBinaryTree.SaveToStrings(Strings: TStrings);
begin
  Strings.Clear;
  AppendToStrings(Strings);
end;

procedure TJclStrBinaryTree.AppendFromStrings(Strings: TStrings);
var
  I: Integer;
begin
  for I := 0 to Strings.Count - 1 do
    Add(Strings[I]);
end;

function TJclStrBinaryTree.GetAsDelimited(Separator: string): string;
var
  It: IJclStrIterator;
begin
  It := First;
  Result := '';
  if It.HasNext then
    Result := It.Next;
  while It.HasNext do
    Result := Result + Separator + It.Next;
end;

procedure TJclStrBinaryTree.LoadDelimited(AString, Separator: string);
begin
  Clear;
  AppendDelimited(AString, Separator);
end;

procedure TJclStrBinaryTree.AppendDelimited(AString, Separator: string);
begin
  DCLAppendDelimited(Self, AString, Separator);
end;
}

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

{$IFDEF RECURSIVE}
  procedure FreeChild(Node: PJclStrBinaryNode);
  begin
    if Node^.Left <> nil then
      FreeChild(Node^.Left);
    if Node^.Right <> nil then
      FreeChild(Node^.Right);
    Node^.Str := ''; // Force Release
    FreeMem(Node);
  end;
{$ELSE}
var
  Current: PJclStrBinaryNode;
  Save: PJclStrBinaryNode;
{$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.Str := ''; // 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 TJclStrBinaryTree.Clone: TObject;
var
  NewTree: TJclStrBinaryTree;

  function CloneNode(Node, Parent: PJclStrBinaryNode): PJclStrBinaryNode;
  begin
    if Node <> nil then
    begin
      GetMem(Result, SizeOf(TJclStrBinaryNode));
      Result.Str := Node^.Str;
      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;