{ *********************************************************************** }
{                                                                         }
{ Delphi Visual Component Library                                         }
{                                                                         }
{ Copyright (c) 2001-2004 Borland Software Corporation                    }
{                                                                         }
{ *********************************************************************** }

unit Borland.Vcl.Contnrs;

interface

uses
  SysUtils, Classes;

type

{ TObjectList class }

  TObjectList = class(TList)
  private
    FOwnsObjects: Boolean;
  protected
    procedure Notify(Instance: TObject; Action: TListNotification); override;
  public
    constructor Create; overload;
    constructor Create(AOwnsObjects: Boolean); overload;

    function FindInstanceOf(AClass: TClass; AExact: Boolean = True; AStartAt: Integer = 0): Integer;
    property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;
  end;

{ TComponentList class }

  TComponentList = class(TObjectList)
  private
    FNexus: TComponent;
  protected
    procedure Notify(Instance: TObject; Action: TListNotification); override;
    function GetItems(Index: Integer): TComponent;
    procedure SetItems(Index: Integer; AComponent: TComponent);
    procedure HandleFreeNotify(Sender: TObject; AComponent: TComponent);
  public
    destructor Destroy; override;

    function Add(AComponent: TComponent): Integer;
    function Extract(Item: TComponent): TComponent;
    function Remove(AComponent: TComponent): Integer;
    function IndexOf(AComponent: TComponent): Integer;
    function First: TComponent;
    function Last: TComponent;
    procedure Insert(Index: Integer; AComponent: TComponent);
    property Items[Index: Integer]: TComponent read GetItems write SetItems; default;
  end;

{ TClassList class }

  TClassList = class(TList)
  protected
    function GetItems(Index: Integer): TClass;
    procedure SetItems(Index: Integer; AClass: TClass);
  public
    function Add(AClass: TClass): Integer;
    function Extract(Item: TClass): TClass;
    function Remove(AClass: TClass): Integer;
    function IndexOf(AClass: TClass): Integer;
    function First: TClass;
    function Last: TClass;
    procedure Insert(Index: Integer; AClass: TClass);
    property Items[Index: Integer]: TClass read GetItems write SetItems; default;
  end;

{ TOrdered class }

  TOrderedList = class(TObject)
  private
    FList: TList;
  protected
    procedure PushItem(AItem: TObject); virtual; abstract;
    function PopItem: TObject; virtual;
    function PeekItem: TObject; virtual;
    property List: TList read FList;
  public
    constructor Create;
    destructor Destroy; override;

    function Count: Integer;
    function AtLeast(ACount: Integer): Boolean;
    function Push(AItem: TObject): TObject;
    function Pop: TObject;
    function Peek: TObject;
  end;

{ TStack class }

  TStack = class(TOrderedList)
  protected
    procedure PushItem(AItem: TObject); override;
  end;

{ TObjectStack class }

  TObjectStack = class(TStack)
  end;

{ TQueue class }

  TQueue = class(TOrderedList)
  protected
    procedure PushItem(AItem: TObject); override;
  end;

{ TObjectQueue class }

  TObjectQueue = class(TQueue)
  end;

{ TBucketList, Hashed associative list }

  TCustomBucketList = class;

  TBucketItem = record
    Item, Data: TObject;
  end;
  TBucketItemArray = array of TBucketItem;

  TBucket = record
    Count: Integer;
    Items: TBucketItemArray;
  end;
  TBucketArray = array of TBucket;

  TBucketProc = procedure(AInfo, AItem, AData: TObject; out AContinue: Boolean);

  TCustomBucketList = class(TObject)
  private
    FBuckets: TBucketArray;
    FBucketCount: Integer;
    FListLocked: Boolean;
    FClearing: Boolean;
    function GetData(AItem: TObject): TObject;
    procedure SetData(AItem: TObject; const AData: TObject);
    procedure SetBucketCount(const Value: Integer);
  protected
    property Buckets: TBucketArray read FBuckets;
    property BucketCount: Integer read FBucketCount write SetBucketCount;

    function BucketFor(AItem: TObject): Integer; virtual; abstract;

    function FindItem(AItem: TObject; out ABucket, AIndex: Integer): Boolean; virtual;
    function AddItem(ABucket: Integer; AItem, AData: TObject): TObject; virtual;
    function DeleteItem(ABucket: Integer; AIndex: Integer): TObject; virtual;
  public
    destructor Destroy; override;
    procedure Clear;

    function Add(AItem, AData: TObject): TObject;
    function Remove(AItem: TObject): TObject;

    function ForEach(AProc: TBucketProc; AInfo: TObject = nil): Boolean;
    procedure Assign(AList: TCustomBucketList);

    function Exists(AItem: TObject): Boolean;
    function Find(AItem: TObject; out AData: TObject): Boolean;
    property Data[AItem: TObject]: TObject read GetData write SetData; default;
  end;

{ TBucketList }

  TBucketListSizes = (bl2, bl4, bl8, bl16, bl32, bl64, bl128, bl256);

  TBucketList = class(TCustomBucketList)
  private
    FBucketMask: Byte;
  protected
    function BucketFor(AItem: TObject): Integer; override;
  public
    constructor Create(ABuckets: TBucketListSizes = bl16);
  end;

{ TObjectBucketList }

  TObjectBucketList = class(TBucketList)
  end;

implementation

uses
  Math, RTLConsts;

{ TObjectList }

constructor TObjectList.Create;
begin
  inherited Create;
  FOwnsObjects := True;
end;

constructor TObjectList.Create(AOwnsObjects: Boolean);
begin
  inherited Create;
  FOwnsObjects := AOwnsObjects;
end;

function TObjectList.FindInstanceOf(AClass: TClass; AExact: Boolean;
  AStartAt: Integer): Integer;
var
  I: Integer;
begin
  Result := -1;
  for I := AStartAt to Count - 1 do
    if (AExact and
        (Items[I].ClassType = AClass)) or
       (not AExact and
        Items[I].InheritsFrom(AClass)) then
    begin
      Result := I;
      break;
    end;
end;

procedure TObjectList.Notify(Instance: TObject; Action: TListNotification);
begin
  if OwnsObjects then
    if Action = lnDeleted then
      Instance.Free;
  inherited Notify(Instance, Action);
end;

{ TComponentListNexus }
{ used by TComponentList to get free notification }

type
  TComponentListNexusEvent = procedure(Sender: TObject; AComponent: TComponent) of object;
  TComponentListNexus = class(TComponent)
  private
    FOnFreeNotify: TComponentListNexusEvent;
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    property OnFreeNotify: TComponentListNexusEvent read FOnFreeNotify write FOnFreeNotify;
  end;

{ TComponentListNexus }

procedure TComponentListNexus.Notification(AComponent: TComponent; Operation: TOperation);
begin
  if (Operation = opRemove) and Assigned(FOnFreeNotify) then
    FOnFreeNotify(Self, AComponent);
  inherited Notification(AComponent, Operation);
end;

{ TComponentList }

function TComponentList.Add(AComponent: TComponent): Integer;
begin
  Result := inherited Add(AComponent);
end;

destructor TComponentList.Destroy;
begin
  inherited Destroy;
  FNexus.Free;
end;

function TComponentList.Extract(Item: TComponent): TComponent;
begin
  Result := TComponent(inherited Extract(Item));
end;

function TComponentList.First: TComponent;
begin
  Result := TComponent(inherited First);
end;

function TComponentList.GetItems(Index: Integer): TComponent;
begin
  Result := TComponent(inherited Items[Index]);
end;

procedure TComponentList.HandleFreeNotify(Sender: TObject; AComponent: TComponent);
begin
  Extract(AComponent);
end;

function TComponentList.IndexOf(AComponent: TComponent): Integer;
begin
  Result := inherited IndexOf(AComponent);
end;

procedure TComponentList.Insert(Index: Integer; AComponent: TComponent);
begin
  inherited Insert(Index, AComponent);
end;

function TComponentList.Last: TComponent;
begin
  Result := TComponent(inherited Last);
end;

procedure TComponentList.Notify(Instance: TObject; Action: TListNotification);
begin
  if not Assigned(FNexus) then
  begin
    FNexus := TComponentListNexus.Create(nil);
    TComponentListNexus(FNexus).OnFreeNotify := HandleFreeNotify;
  end;
  case Action of
    lnAdded:
      if Instance <> nil then
        TComponent(Instance).FreeNotification(FNexus);
    lnExtracted,
    lnDeleted:
      if Instance <> nil then
        TComponent(Instance).RemoveFreeNotification(FNexus);
  end;
  inherited Notify(Instance, Action);
end;

function TComponentList.Remove(AComponent: TComponent): Integer;
begin
  Result := inherited Remove(AComponent);
end;

procedure TComponentList.SetItems(Index: Integer; AComponent: TComponent);
begin
  inherited Items[Index] := AComponent;
end;

{ TClassList }

function TClassList.Add(AClass: TClass): Integer;
begin
  Result := inherited Add(TObject(AClass));
end;

function TClassList.Extract(Item: TClass): TClass;
begin
  Result := TClass(inherited Extract(TObject(Item)));
end;

function TClassList.First: TClass;
begin
  Result := TClass(inherited First);
end;

function TClassList.GetItems(Index: Integer): TClass;
begin
  Result := TClass(inherited Items[Index]);
end;

function TClassList.IndexOf(AClass: TClass): Integer;
begin
  Result := inherited IndexOf(TObject(AClass));
end;

procedure TClassList.Insert(Index: Integer; AClass: TClass);
begin
  inherited Insert(Index, TObject(AClass));
end;

function TClassList.Last: TClass;
begin
  Result := TClass(inherited Last);
end;

function TClassList.Remove(AClass: TClass): Integer;
begin
  Result := inherited Remove(TObject(AClass));
end;

procedure TClassList.SetItems(Index: Integer; AClass: TClass);
begin
  inherited Items[Index] := TObject(AClass);
end;

{ TOrderedList }

function TOrderedList.AtLeast(ACount: integer): boolean;
begin
  Result := List.Count >= ACount;
end;

function TOrderedList.Peek: TObject;
begin
  Result := PeekItem;
end;

function TOrderedList.Pop: TObject;
begin
  Result := PopItem;
end;

function TOrderedList.Push(AItem: TObject): TObject;
begin
  PushItem(AItem);
  Result := AItem;
end;

function TOrderedList.Count: Integer;
begin
  Result := List.Count;
end;

constructor TOrderedList.Create;
begin
  inherited Create;
  FList := TList.Create;
end;

destructor TOrderedList.Destroy;
begin
  List.Free;
  inherited Destroy;
end;

function TOrderedList.PeekItem: TObject;
begin
  Result := List[List.Count-1];
end;

function TOrderedList.PopItem: TObject;
begin
  Result := PeekItem;
  List.Delete(List.Count-1);
end;

{ TStack }

procedure TStack.PushItem(AItem: TObject);
begin
  List.Add(AItem);
end;

{ TQueue }

procedure TQueue.PushItem(AItem: TObject);
begin
  List.Insert(0, AItem);
end;

{ TCustomBucketList }

function TCustomBucketList.Add(AItem, AData: TObject): TObject;
var
  LBucket: Integer;
  LIndex: Integer;
begin
  if FListLocked then
    raise EListError.Create(SBucketListLocked);
  if FindItem(AItem, LBucket, LIndex) then
    raise EListError.CreateFmt(SDuplicateItem, [Integer(AItem)])
  else
    Result := AddItem(LBucket, AItem, AData);
end;

function TCustomBucketList.AddItem(ABucket: Integer; AItem, AData: TObject): TObject;
var
  LDelta, LSize: Integer;
begin
  with Buckets[ABucket] do
  begin
    LSize := Length(Items);
    if Count = LSize then
    begin
      if LSize > 64 then
        LDelta := LSize div 4
      else if LSize > 8 then
        LDelta := 16
      else
        LDelta := 4;
      SetLength(Items, LSize + LDelta);
    end;

    with Items[Count] do
    begin
      Item := AItem;
      Data := AData;
    end;
    Inc(Count);
  end;
  Result := AData;
end;

procedure AssignProc(AInfo, AItem, AData: TObject; out AContinue: Boolean);
begin
  TCustomBucketList(AInfo).Add(AItem, AData);
end;

procedure TCustomBucketList.Assign(AList: TCustomBucketList);
begin
  Clear;
  AList.ForEach(AssignProc, Self);
end;

procedure TCustomBucketList.Clear;
var
  LBucket, LIndex: Integer;
begin
  if FListLocked then
    raise EListError.Create(SBucketListLocked);
  
  FClearing := True;
  try
    for LBucket := 0 to BucketCount - 1 do
    begin
      for LIndex := Buckets[LBucket].Count - 1 downto 0 do 
        DeleteItem(LBucket, LIndex);

      SetLength(Buckets[LBucket].Items, 0);
      Buckets[LBucket].Count := 0;
    end;
  finally
    FClearing := False;
  end;
end;

function TCustomBucketList.DeleteItem(ABucket, AIndex: Integer): TObject;
var
  I: Integer;
begin
  with Buckets[ABucket] do
  begin
    Result := Items[AIndex].Data;

    if not FClearing then
    begin
      if Count = 1 then
        SetLength(Items, 0)
      else
        for I := AIndex + 1 to Count - 1 do
          Items[I - 1] := Items[I];
      Dec(Count);
    end;
  end;
end;

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

function TCustomBucketList.Exists(AItem: TObject): Boolean;
var
  LBucket, LIndex: Integer;
begin
  Result := FindItem(AItem, LBucket, LIndex);
end;

function TCustomBucketList.Find(AItem: TObject; out AData: TObject): Boolean;
var
  LBucket, LIndex: Integer;
begin
  Result := FindItem(AItem, LBucket, LIndex);
  if Result then
    AData := Buckets[LBucket].Items[LIndex].Data;
end;

function TCustomBucketList.FindItem(AItem: TObject; out ABucket, AIndex: Integer): Boolean;
var
  I: Integer;
begin
  Result := False;
  ABucket := BucketFor(AItem);
  with FBuckets[ABucket] do
    for I := 0 to Count - 1 do
      if Items[I].Item = AItem then
      begin
        AIndex := I;
        Result := True;
        Break;
      end;
end;

function TCustomBucketList.ForEach(AProc: TBucketProc; AInfo: TObject): Boolean;
var
  LBucket, LIndex: Integer;
  LOldListLocked: Boolean;
begin
  Result := True;
  LOldListLocked := FListLocked;
  FListLocked := True;
  try
    for LBucket := 0 to BucketCount - 1 do
      with Buckets[LBucket] do
        for LIndex := Count - 1 downto 0 do
        begin
          with Items[LIndex] do
            AProc(AInfo, Item, Data, Result);
          if not Result then
            Exit;
        end;
  finally
    FListLocked := LOldListLocked;
  end;
end;

function TCustomBucketList.GetData(AItem: TObject): TObject;
var
  LBucket, LIndex: Integer;
begin
  if not FindItem(AItem, LBucket, LIndex) then
    raise EListError.CreateFmt(SItemNotFoundWithPrefix, [HexDisplayPrefix, Integer(AItem)]);
  Result := Buckets[LBucket].Items[LIndex].Data;
end;

function TCustomBucketList.Remove(AItem: TObject): TObject;
var
  LBucket, LIndex: Integer;
begin
  if FListLocked then
    raise EListError.Create(SBucketListLocked);
  Result := nil;
  if FindItem(AItem, LBucket, LIndex) then
    Result := DeleteItem(LBucket, LIndex);
end;

procedure TCustomBucketList.SetBucketCount(const Value: Integer);
begin
  if Value <> FBucketCount then
  begin
    FBucketCount := Value;
    SetLength(FBuckets, FBucketCount);
  end;
end;

procedure TCustomBucketList.SetData(AItem: TObject; const AData: TObject);
var
  LBucket, LIndex: Integer;
begin
  if not FindItem(AItem, LBucket, LIndex) then
    raise EListError.CreateFmt(SItemNotFoundWithPrefix, [HexDisplayPrefix, Integer(AItem)]);
  Buckets[LBucket].Items[LIndex].Data := AData;
end;

{ TBucketList }

function TBucketList.BucketFor(AItem: TObject): Integer;
begin
  // this can be overridden with your own calculation but remember to
  //  keep it in sync with your bucket count.

  Result := AItem.GetHashCode and FBucketMask;
end;

const
  cBucketMasks: array [TBucketListSizes] of Byte =
    ($01, $03, $07, $0F, $1F, $3F, $7F, $FF);

constructor TBucketList.Create(ABuckets: TBucketListSizes);
begin
  inherited Create;
  FBucketMask := CBucketMasks[ABuckets];
  BucketCount := FBucketMask + 1;
end;

end.
