jclbinarytrees.pas

East make Tray Icon in delphi

  end;

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

function TJclStrBinaryTree.Contains(const AString: string): Boolean;
var
  {$IFDEF THREADSAFE}
  CS: IInterface;
  {$ENDIF THREADSAFE}
  Comp: Integer;

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

begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  Result := False;
  if AString = '' then
    Exit;
  {$IFDEF RECURSIVE}
  // recursive version
  Result := ContainsChild(FRoot);
  {$ELSE}
  // iterative version
  Current := FRoot;
  while Current <> nil do
  begin
    Comp := FComparator(Current.Str, AString);
    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 TJclStrBinaryTree.ContainsAll(ACollection: IJclStrCollection): Boolean;
var
  It: IJclStrIterator;
  {$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 TJclStrBinaryTree.Equals(ACollection: IJclStrCollection): Boolean;
var
  It, ItSelf: IJclStrIterator;
  {$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 TJclStrBinaryTree.First: IJclStrIterator;
begin
  case GetTraverseOrder of
    toPreOrder:
      Result := TPreOrderStrItr.Create(Self, FRoot);
    toOrder:
      Result := TInOrderStrItr.Create(Self, FRoot);
    toPostOrder:
      Result := TPostOrderStrItr.Create(Self, FRoot);
  end;
end;

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

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

function TJclStrBinaryTree.Last: IJclStrIterator;
var
  Start: PJclStrBinaryNode;
begin
  Start := FRoot;
  case FTraverseOrder of
    toPreOrder:
      begin
        if Start <> nil then
          while Start.Right <> nil do
            Start := Start.Right;
        Result := TPreOrderStrItr.Create(Self, Start);
      end;
    toOrder:
      begin
        if Start <> nil then
          while Start.Right <> nil do
            Start := Start.Right;
        Result := TInOrderStrItr.Create(Self, Start);
      end;
    toPostOrder:
      Result := TPostOrderStrItr.Create(Self, Start);
  end;
end;

function TJclStrBinaryTree.Remove(const AString: string): Boolean;
var
  Current: PJclStrBinaryNode;
  Node: PJclStrBinaryNode;
  Save: PJclStrBinaryNode;
  Comp: Integer;
  {$IFDEF THREADSAFE}
  CS: IInterface;
  {$ENDIF THREADSAFE}

  procedure Correction(Node: PJclStrBinaryNode);
  var
    TempNode: PJclStrBinaryNode;
  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 AString = '' then
    Exit;
  // locate AObject in the tree
  Current := FRoot;
  while Current <> nil do
  begin
    Comp := FComparator(AString, Current.Str);
    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
      Correction(Node);
  end
  else
  if Save.Parent = nil then
    FRoot := nil
  else
  begin
    if Save.Color = tcBlack then // Correction
      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 TJclStrBinaryTree.RemoveAll(ACollection: IJclStrCollection): Boolean;
var
  It: IJclStrIterator;
  {$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 TJclStrBinaryTree.RetainAll(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 := First;
  while It.HasNext do
    if not ACollection.Contains(It.Next) then
      It.Remove;
end;

procedure TJclStrBinaryTree.RotateLeft(Node: PJclStrBinaryNode);
var
  TempNode: PJclStrBinaryNode;
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 TJclStrBinaryTree.RotateRight(Node: PJclStrBinaryNode);
var
  TempNode: PJclStrBinaryNode;
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
    Node^.Parent^.Left := TempNode;
  TempNode^.Right := Node;
  Node^.Parent := TempNode;
end;

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

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

//=== { TJclBinaryTree } =====================================================

constructor TJclBinaryTree.Create(AComparator: TCompare = nil);
begin
  inherited Create;
  if Assigned(AComparator) then
    FComparator := AComparator
  else
    FComparator := @SimpleCompare;
  FTraverseOrder := toPreOrder;
end;

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

function TJclBinaryTree.Add(AObject: TObject): Boolean;
var
  NewNode: PJclBinaryNode;
  Current, Save: PJclBinaryNode;
  {$IFDEF THREADSAFE}
  CS: IInterface;
  {$ENDIF THREADSAFE}
begin
  {$IFDEF THREADSAFE}
  CS := EnterCriticalSection;
  {$ENDIF THREADSAFE}
  Result := False;
  if AObject = nil then
    Exit;
  NewNode := AllocMem(SizeOf(TJclBinaryNode));
  NewNode^.Obj := AObject;
  // 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