[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    unit Collect;
    { Collection classes for Delphi 2.0
      Alin Flaider, 1996
      aflaidar@datalog.ro }

    interface
    uses Windows, Classes, Sysutils;

    const
      coIndexError = -1;              { Index out of range }
      coOverflow   = -2;              { Overflow }
      coUnderflow  = -3;              { Underflow }

    type
     CollException = class(Exception);

     TCollection = class( TObject)
        private                       { return item at index position }
           function    At( Index : integer) : Pointer;
                                      { replace item at index position}
           procedure   AtPut( Index : integer; Item : Pointer);
        protected
           It     : PPointerList;     { array of pointers }
           Limit  : integer;          { Current Allocated size of array}
           Delta  : integer;          {Number of items by which the collection grows when full}
                                      { deletes item at index position }
           procedure   AtDelete      (Index : integer);
                                      { generates CollException }
           procedure   Error         (Code,Info : Integer); virtual;
                                      { destroys specified Item; override this method if Item is not
                                        a descendant of TObject }
           procedure   FreeItem      (Item : Pointer); virtual;
        public
           Count  : integer;          {Current Number of Items}
           constructor create(aLimit, aDelta : integer);
                                      {before deallocating object it disposes all items and the storage array}
           destructor  destroy; override;
                                      {inserts Item at specified position }
           procedure   AtInsert( Index : integer; Item : Pointer);
                                      {deletes and disposes Item at specified position}
           procedure   AtFree(Index: Integer);
                                      {deletes Item}
           procedure   Delete( Item : Pointer);
                                      {deletes all Items without disposing them }
           procedure   DeleteAll;
                                      {formerly Free, renamed to Clear to avoid bypassing inherited TObject.Free;
                                       deletes and disposes Item }
           procedure Clear(Item: Pointer);
                                      {finds first item that satisfies condition specified in
                                       function Test( Item: pointer): boolean}
           function    FirstThat( Test : Pointer) : Pointer;
                                      {finds last item that satisfies condition specified in
                                       function Test( Item: pointer): boolean}
           function    LastThat( Test : Pointer) : Pointer;
                                      {calls procedure Action( Item: pointer) for each item in collection}
           procedure   ForEach( Action : Pointer);
                                      {disposes all items; set counter to zero}
           procedure   FreeAll;
                                      {finds position of Item using a linear search}
           function    IndexOf( Item : Pointer) : integer; virtual;
                                      {inserts Item at the end of collection}
           procedure   Insert( Item : Pointer); virtual;
                                      {packs collection by removing nil Items}
           procedure   Pack;
                                      {expands array of pointers }
           procedure   SetLimit( aLimit : integer);virtual;
                                      {direct access to items through position}
           property Items[Index: integer]: pointer read At write AtPut; default;
        end;

        TSortedCollection = class(TCollection)
           Duplicates: boolean;       {if true, rejects item whose key already exists}
                                      {override this method to specify relation bewtween two keys
                                      1 if Key1 comes after Key2, -1 if Key1 comes before Key2,
                                      0 if Key1 is equivalent to Key2}
           function Compare (Key1,Key2 : Pointer): Integer; virtual; abstract;
                                      {returns key of Item}
           function KeyOf   (Item : Pointer): Pointer; virtual;
                                      {finds index of item by calling Search}
           function IndexOf (Item : Pointer): integer; virtual;
                                      {finds item required position and performs insertion }
           procedure Insert  (Item : Pointer); virtual;
                                      {finds index of item by performing an optimised search}
           function Search  (key : Pointer; Var Index : integer) : Boolean; virtual;
        end;

    implementation

    constructor TCollection.Create(ALimit, ADelta: Integer);
    begin
       inherited Create;
       Limit:= 0;
       Delta:=aDelta;
       Count:=0;
       It := nil;
       SetLimit( ALimit);
    end;

    destructor TCollection.Destroy;
    begin
       FreeAll;
       SetLimit(0);
       inherited Destroy;
    end;

    function TCollection.At(Index: Integer): Pointer;
    begin
       If Index > pred(Count) then
       begin
         Error(coIndexError,0);
         Result :=nil;
       end
       else Result := It^[Index];
    end;

    procedure TCollection.AtPut(Index: Integer; Item: Pointer);
    begin
       if (Index < 0) or (Index >= Count) then
         Error(coIndexError,0)
       else It^[Index] := Item;
    end;

    procedure TCollection.AtDelete(Index: Integer);
    var p: pointer;
    begin
       if (Index < 0) or (Index >= Count) then
       begin
          Error(coIndexError,0);
          exit;
       end;
       if Index < pred(Count) then
         move( It^[succ(Index)], It^[Index], (count-index)*sizeof(pointer));
       Dec(Count);
    end;

    procedure TCollection.AtInsert( Index: integer; Item: pointer);
    var i : integer;
    begin
       if (Index < 0) or ( Index > Count) then
       begin
          Error(coIndexError,0);
          exit;
       end;
       if Limit = Count then
       begin
         if Delta = 0 then
         begin
            Error(coOverFlow,0);
            exit;
         end;
         SetLimit( Limit+Delta);
       end;
       If Index <> Count then  {move compensates for overlaps}
          move( It^[Index], It^[Index+1], (count - index)*sizeof(pointer));
       It^[Index] := Item;
       Inc(Count);
    end;

    procedure TCollection.Delete( Item: pointer);
    begin
       AtDelete(Indexof(Item));
    end;

    procedure TCollection.DeleteAll;
    begin
       Count:=0
    end;

    procedure TCollection.Error(Code, Info: Integer);
    begin
       case Code of
            coIndexError: raise CollException.Create('Collection error; wrong index: '+IntToStr(Info));
            coOverflow:  raise CollException.Create('Collection overflow - cannot grow!');
            coUnderflow: raise CollException.Create('Collection underflow - cannot shrink!');
       end
    end;

    function TCollection.FirstThat(Test: Pointer): Pointer;
    type
       tTestFunc = function( p : pointer) : Boolean;
    var i : integer;
    begin
      Result := nil;
      for i := 0 to pred(count) do
        if tTestFunc(test)(It^[i]) then begin
           Result := It[i];
           break
        end
    end;

    procedure TCollection.ForEach(Action: Pointer);
    type
       tActionProc = procedure(p : pointer);
    var i : integer;
    begin
      for i := 0 to pred(Count) do
        tActionProc(Action)(It^[i]);
    end;

    procedure TCollection.Clear(Item: Pointer);
    begin
       Delete(Item);
       FreeItem(Item);
    end;

    procedure TCollection.FreeAll;
    var i : integer;
    begin
      for I := 0 to Count - 1 do FreeItem(At(I));
      Count := 0;
    end;

    procedure TCollection.FreeItem(Item: Pointer);
    begin
      if Item <> nil then TObject(Item).Free;
    end;

    function TCollection.IndexOf(Item: Pointer): integer;
    var i : integer;
    begin
      Result := -1;
      for i := 0 to pred(count) do
        if Item = It^[i] then begin
           Result := i;
           break
        end
    end;

    procedure TCollection.Insert(Item: Pointer);
    begin
       AtInsert(Count,Item);
    end;

    function TCollection.LastThat(Test: Pointer): pointer;
    type
       tTestFunc = function( p : pointer) : Boolean;
    var i : integer;
    begin
      Result := nil;
      for i := pred(count) downto 1 do
        if tTestFunc(test)(It^[i]) then begin
           Result := It^[i];
           break
        end
    end;

    procedure TCollection.Pack;
    var i: integer;
    begin
      for i := pred(count) downto 0 do if It^[i] = nil then AtDelete(i);
    end;

    procedure TCollection.SetLimit(ALimit: Integer);
    begin
      if (ALimit < Count) then Error( coUnderFlow , 0);
      if ALimit <> Limit then
      begin
        ReallocMem( It, ALimit* SizeOf(Pointer));
        Limit := ALimit;
      end;
    end;

    function TSortedCollection.IndexOf(Item: Pointer): Integer;
    var
      i: Integer;
    begin
      IndexOf := -1;
      if Search(KeyOf(Item), i) then
      begin
        if Duplicates then
          while (i < Count) and (Item <> It^[I]) do Inc(i);
        if i < Count then IndexOf := i;
      end;
    end;

    procedure TSortedCollection.Insert(Item: Pointer);
    var i : integer;
    begin
      if not Search(KeyOf(Item), I) or Duplicates then AtInsert(I, Item);
    end;

    function TSortedCollection.KeyOf(Item: Pointer): Pointer;
    begin
      Result := Item;
    end;

    function TSortedCollection.Search;
    var
      L, H, I, C: Integer;
    begin
      Search := False;
      L := 0;
      H := Count - 1;
      while L <= H do
      begin
        I := (L + H) shr 1;
        C := Compare(KeyOf(It^[I]), Key);
        if C < 0 then L := I + 1 else
        begin
          H := I - 1;
          if C = 0 then
          begin
            Search := True;
            if not Duplicates then L := I;
          end;
        end;
      end;
      Index := L;
    end;

    procedure TCollection.AtFree(Index: Integer);
    var
      Item: Pointer;
    begin
      Item := At(Index);
      AtDelete(Index);
      FreeItem(Item);
    end;

    end.

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]