lazarus/lcl/dynhasharray.pp

{
  Author: Mattias Gaertner

 *****************************************************************************
 *                                                                           *
 *  This file is part of the Lazarus Component Library (LCL)                 *
 *                                                                           *
 *  See the file COPYING.modifiedLGPL.txt, included in this distribution,    *
 *  for details about the copyright.                                         *
 *                                                                           *
 *  This program is distributed in the hope that it will be useful,          *
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
 *                                                                           *
 *****************************************************************************
 
  Abstract:
    This unit defines TDynHashArray, which is very similar to a TList, since
    it also stores pointer/objects.
    It supports Add, Remove, Contains, First, Count and Clear.
    Because of the hashing nature the operations adding, removing and finding is
    done in constant time on average.
    
    Inner structure:
      There are three parts:
        1. The array itself (FItems). Every entry is a pointer to the first
           TDynHashArrayItem of a list with the same hash index. The first item
           of every same index list is the list beginning and its IsOverflow
           flag is set to false. All other items are overflow items.
           To get all items with the same hash index, do a FindHashItem. Then
           search through all "Next" items until Next is nil or its IsOverflow
           flag is set to false.
        2. The items beginning with FFirstItem is a 2-way-connected list of
           TDynHashArrayItem. This list contains all used items.
        3. To reduce GetMem/FreeMem calls, free items are cached.

  Issues:
    The maximum capacity is the PrimeNumber. You can store more items, but the
    performance decreases. The best idea is to provide your own hash function.
    
    Important: Items in the TDynHashArray must not change their key.
      When changing the key of an item, remove it and add it after the change.

}
unit DynHashArray;

{$Mode ObjFPC}{$H+}

interface

uses Classes, SysUtils, LCLProc;

type
  TDynHashArray = class;
  
  THashFunction = function(Sender: TDynHashArray; Item: Pointer): integer;
  TOwnerHashFunction = function(Item: Pointer): integer of object;
  TOnGetKeyForHashItem = function(Item: pointer): pointer;
  TOnEachHashItem = function(Sender: TDynHashArray; Item: Pointer): boolean;

  PDynHashArrayItem = ^TDynHashArrayItem;
  TDynHashArrayItem = record
    Item: Pointer;
    Next, Prior: PDynHashArrayItem;
    IsOverflow: boolean;
  end; 
  
  TDynHashArrayOption = (dhaoCachingEnabled, dhaoCacheContains);
  TDynHashArrayOptions = set of TDynHashArrayOption;
  
  { TDynHashArray }

  TDynHashArray = class
  private
    FItems: ^PDynHashArrayItem;
    FCount: integer;
    FCapacity: integer;
    FMinCapacity: integer;
    FMaxCapacity: integer;
    FFirstItem: PDynHashArrayItem;
    FHashCacheItem: Pointer;
    FHashCacheIndex: integer;
    FLowWaterMark: integer;
    FHighWaterMark: integer;
    FCustomHashFunction: THashFunction;
    FOnGetKeyForHashItem: TOnGetKeyForHashItem;
    FOptions: TDynHashArrayOptions;
    FOwnerHashFunction: TOwnerHashFunction;
    FContainsCache: TObject;
    function NewHashItem: PDynHashArrayItem;
    procedure DisposeHashItem(ADynHashArrayItem: PDynHashArrayItem);
    procedure ComputeWaterMarks;
    procedure SetCapacity(NewCapacity: integer);
    procedure SetCustomHashFunction(const AValue: THashFunction);
    procedure SetOnGetKeyForHashItem(const AValue: TOnGetKeyForHashItem);
    procedure SetOptions(const AValue: TDynHashArrayOptions);
    procedure SetOwnerHashFunction(const AValue: TOwnerHashFunction);
  protected
    procedure RebuildItems;
    procedure SaveCacheItem(Item: Pointer; Index: integer);
  public
    constructor Create;
    constructor Create(InitialMinCapacity: integer);
    destructor Destroy; override;
    procedure Add(Item: Pointer);
    function Contains(Item: Pointer): boolean;
    function ContainsKey(Key: Pointer): boolean;
    procedure Remove(Item: Pointer);
    procedure Clear;
    procedure ClearCache;
    function First: Pointer;
    property Count: integer read fCount;
    function IndexOf(AnItem: Pointer): integer;
    function IndexOfKey(Key: Pointer): integer;
    function FindHashItem(Item: Pointer): PDynHashArrayItem;
    function FindHashItemWithKey(Key: Pointer): PDynHashArrayItem;
    function FindItemWithKey(Key: Pointer): Pointer;
    function GetHashItem(HashIndex: integer): PDynHashArrayItem;
    procedure Delete(ADynHashArrayItem: PDynHashArrayItem);
    procedure AssignTo(List: TList);
    procedure AssignTo(List: TFPList);
    procedure ForEach(const Func: TOnEachHashItem);

    function SlowAlternativeHashMethod(Sender: TDynHashArray;
       Item: Pointer): integer;
    function ConsistencyCheck: integer;
    procedure WriteDebugReport;

    property FirstHashItem: PDynHashArrayItem read FFirstItem;
    property MinCapacity: integer read FMinCapacity write FMinCapacity;
    property MaxCapacity: integer read FMaxCapacity write FMaxCapacity;
    property Capacity: integer read FCapacity;
    property CustomHashFunction: THashFunction
       read FCustomHashFunction write SetCustomHashFunction;
    property OwnerHashFunction: TOwnerHashFunction
       read FOwnerHashFunction write SetOwnerHashFunction;
    property OnGetKeyForHashItem: TOnGetKeyForHashItem
       read FOnGetKeyForHashItem write SetOnGetKeyForHashItem;
    property Options: TDynHashArrayOptions read FOptions write SetOptions;
  end;

  TDynHashArrayItemMemManager = class
  private
    FFirstFree: PDynHashArrayItem;
    FFreeCount: integer;
    FCount: integer;
    FMinFree: integer;
    FMaxFreeRatio: integer;
    procedure SetMaxFreeRatio(NewValue: integer);
    procedure SetMinFree(NewValue: integer);
    procedure DisposeFirstFreeItem;
  public
    procedure DisposeItem(ADynHashArrayItem: PDynHashArrayItem);
    function NewItem: PDynHashArrayItem;
    property MinimumFreeCount: integer read FMinFree write SetMinFree;
    property MaximumFreeRatio: integer
        read FMaxFreeRatio write SetMaxFreeRatio; // in one eighth steps
    property Count: integer read FCount;
    procedure Clear;
    constructor Create;
    destructor Destroy; override;
    function ConsistencyCheck: integer;
    procedure WriteDebugReport;
  end;
  
  EDynHashArrayException = class(Exception);
  
const
  ItemMemManager: TDynHashArrayItemMemManager = nil;

implementation

function GetItemMemManager: TDynHashArrayItemMemManager;
begin
  if ItemMemManager=nil then
    ItemMemManager:=TDynHashArrayItemMemManager.Create;
  Result:=ItemMemManager;
end;

const
  PrimeNumber: integer = 5364329;
  
  
type
  TRecentList = class
  private
    FCapacity: integer;
    FCount: integer;
    FItems: PPointer;
    procedure FreeItems;
    procedure SetCapacity(NewCapacity: integer);
  public
    constructor Create(TheCapacity: integer);
    destructor Destroy; override;
    function Contains(Item: Pointer): boolean;
    procedure Add(Item: Pointer);
    procedure Remove(Item: Pointer);
    function IndexOf(Item: Pointer): integer;
    procedure Clear;
    function ConsistencyCheck: integer;
    property Cacpacity: integer read FCapacity;
    property Count: integer read FCount;
  end;

{ TRecentList }

procedure TRecentList.FreeItems;
begin
  if FItems<>nil then begin
    FreeMem(FItems);
    FItems:=nil;
  end;
end;

procedure TRecentList.SetCapacity(NewCapacity: integer);
begin
  if NewCapacity=FCapacity then exit;
  if NewCapacity>0 then
    ReAllocMem(FItems,NewCapacity*SizeOf(Pointer))
  else
    FreeItems;
  FCapacity:=NewCapacity;
  if FCount>FCapacity then FCount:=FCapacity;
end;

constructor TRecentList.Create(TheCapacity: integer);
begin
  inherited Create;
  if TheCapacity<1 then FCapacity:=1;
  SetCapacity(TheCapacity);
end;

destructor TRecentList.Destroy;
begin
  FreeItems;
  inherited Destroy;
end;

function TRecentList.Contains(Item: Pointer): boolean;
begin
  Result:=IndexOf(Item)>=0;
end;

procedure TRecentList.Add(Item: Pointer);
begin
  if FCount=FCapacity then begin
    if FCount>1 then
      Move(FItems[1],FItems[0],SizeOf(PPointer)*(FCount-1));
  end else begin
    inc(FCount);
  end;
  FItems[FCount-1]:=Item;
end;

procedure TRecentList.Remove(Item: Pointer);
var i: integer;
begin
  i:=IndexOf(Item);
  if i<0 then exit;
  if i<FCount-1 then
    Move(FItems[i+1],FItems[i],SizeOf(PPointer)*(FCount-i-1));
  dec(FCount);
end;

function TRecentList.IndexOf(Item: Pointer): integer;
begin
  Result:=FCount-1;
  while (Result>=0) and (FItems[Result]<>Item) do dec(Result);
end;

procedure TRecentList.Clear;
begin
  FCount:=0;
end;

function TRecentList.ConsistencyCheck: integer;
begin
  if FCount>FCapacity then exit(-1);
  if FCapacity=0 then exit(-2);
  if FItems=nil then exit(-3);
  Result:=0;
end;

{ TDynHashArray }

procedure TDynHashArray.WriteDebugReport;
var i, RealHashIndex: integer;
  HashItem: PDynHashArrayItem;
begin
  DebugLn('TDynHashArray.WriteDebugReport: Consistency=',dbgs(ConsistencyCheck));
  DebugLn('  Count=',dbgs(FCount),'  Capacity=',dbgs(FCapacity));
  for i:=0 to FCapacity-1 do begin
    HashItem:=FItems[i];
    if HashItem<>nil then begin
      DbgOut('  Index=',IntToStr(i));
      while HashItem<>nil do begin
        DbgOut(' ',Dbgs(HashItem^.Item));
        RealHashIndex:=IndexOf(HashItem^.Item);
        if RealHashIndex<>i then DbgOut('(H='+dbgs(RealHashIndex)+')');
        HashItem:=HashItem^.Next;
        if (HashItem<>nil) and (HashItem^.IsOverflow=false) then break;
      end;
      DebugLn;
    end;
  end;
  HashItem:=FFirstItem;
  while HashItem<>nil do begin
    DebugLn('  ',Dbgs(HashItem^.Prior),'<-'
                ,Dbgs(HashItem)
                ,'(',Dbgs(HashItem^.Item),')'
                ,'->',Dbgs(HashItem^.Next));
    HashItem:=HashItem^.Next;
  end;
end;

constructor TDynHashArray.Create(InitialMinCapacity: integer);
var Size: integer;
begin
  inherited Create;
  FMinCapacity:=InitialMinCapacity;
  FMaxCapacity:=PrimeNumber;
  if FMinCapacity<5 then FMinCapacity:=137;
  FCapacity:=FMinCapacity;
  Size:=FCapacity * SizeOf(TDynHashArrayItem);
  GetMem(FItems,Size);
  FillChar(FItems^,Size,0);
  FCount:=0;
  FFirstItem:=nil;
  ComputeWaterMarks;
  FHashCacheIndex:=-1;
end;

destructor TDynHashArray.Destroy;
begin
  Clear;
  FreeMem(FItems);
  FContainsCache.Free;
  inherited Destroy;
end;

function TDynHashArray.ConsistencyCheck: integer;
var RealCount, i: integer;
  HashItem, HashItem2: PDynHashArrayItem;
  OldCacheItem: pointer;
  OldCacheIndex: integer;
begin
  RealCount:=0;
  // check first item
  if (FFirstItem<>nil) and (FFirstItem^.IsOverflow) then
    exit(-1);
  if (FItems=nil) and (FFirstItem<>nil) then
    exit(-2);
  // check for doubles and circles
  HashItem:=FFirstItem;
  while HashItem<>nil do begin
    HashItem2:=HashItem^.Prior;
    while HashItem2<>nil do begin
      if HashItem=HashItem2 then
        exit(-3); // circle
      if HashItem^.Item=HashItem2^.Item then
        exit(-4); // double item
      HashItem2:=HashItem2^.Prior;
    end;
    HashItem:=HashItem^.Next;
  end;
  // check chain
  HashItem:=FFirstItem;
  while HashItem<>nil do begin
    inc(RealCount);
    if (HashItem^.Next<>nil) and (HashItem^.Next^.Prior<>HashItem) then
      exit(-6);
    if (HashItem^.Prior<>nil) and (HashItem^.Prior^.Next<>HashItem) then
      exit(-7);
    if (HashItem^.IsOverflow=false)
    and (FItems[IndexOf(HashItem^.Item)]<>HashItem) then
      exit(-8);
    HashItem:=HashItem^.Next;
  end;
  // check count
  if RealCount<>FCount then exit(-9);
  // check FItems
  RealCount:=0;
  for i:=0 to FCapacity-1 do begin
    HashItem:=FItems[i];
    while HashItem<>nil do begin
      inc(RealCount);
      if IndexOf(HashItem^.Item)<>i then exit(-14);
      HashItem:=HashItem^.Next;
      if (HashItem<>nil) and (HashItem^.IsOverflow=false) then break;
    end;
  end;  
  if RealCount<>FCount then exit(-15);
  // check cache
  if FHashCacheIndex>=0 then begin
    OldCacheItem:=FHashCacheItem;
    OldCacheIndex:=FHashCacheIndex;
    ClearCache;
    FHashCacheIndex:=IndexOfKey(OldCacheItem);
    if FHashCacheIndex<>OldCacheIndex then exit(-16);
    FHashCacheItem:=OldCacheItem;
  end;
  // check ContainsCache
  if (FContainsCache<>nil) xor (dhaoCacheContains in Options) then exit(-17);
  if (FContainsCache<>nil) then begin
    Result:=TRecentList(FContainsCache).ConsistencyCheck;
    if Result<>0 then begin
      dec(Result,100);
      exit;
    end;
  end;
  Result:=0;
end;

procedure TDynHashArray.ComputeWaterMarks;
begin
  FLowWaterMark:=FCapacity div 4;
  FHighWaterMark:=(FCapacity*3) div 4;
end;

function TDynHashArray.IndexOf(AnItem: Pointer): integer;
begin
  if (AnItem<>nil) and (FItems<>nil) then begin
    if Assigned(OnGetKeyForHashItem) then begin
      AnItem:=OnGetKeyForHashItem(AnItem);
    end;
    Result:=IndexOfKey(AnItem);
  end else
    Result:=-1;
end;

function TDynHashArray.IndexOfKey(Key: Pointer): integer;
begin
  if (FItems<>nil)
  and ((Key<>nil) or Assigned(OnGetKeyForHashItem)) then begin

    if (dhaoCachingEnabled in Options)
    and (Key=FHashCacheItem) and (FHashCacheIndex>=0) then
      exit(FHashCacheIndex);
    if not Assigned(FCustomHashFunction) then begin
      if not Assigned(FOwnerHashFunction) then begin
        Result:=Integer((PtrUInt(Key)+(PtrUint(Key) mod 17)) mod Cardinal(FCapacity));
      end else
        Result:=FOwnerHashFunction(Key);
    end else
      Result:=FCustomHashFunction(Self,Key);
    {if (Key=FHashCacheItem) and (FHashCacheIndex>=0)
    and (Result<>FHashCacheIndex) then begin
      DebugLn(' DAMN: ',HexStr(PtrInt(Key),8),' ',FHashCacheIndex,'<>',Result);
      raise Exception.Create('GROSSER MIST');
    end;}
    // Check if the owner or custon function has returned something valid
    if (Result < 0)
    or (Result >= FCapacity)
    then raise EDynHashArrayException.CreateFmt('Invalid index %d for key %p', [Result, Key]);
  end else
    Result:=-1;
end;

procedure TDynHashArray.Clear;
begin
  ClearCache;
  while FFirstItem<>nil do Delete(FFirstItem);
end;

procedure TDynHashArray.ClearCache;
begin
  FHashCacheIndex:=-1;
  if FContainsCache<>nil then TRecentList(FContainsCache).Clear;
end;

procedure TDynHashArray.Add(Item: Pointer);
var Index: integer;
  HashItem: PDynHashArrayItem;
begin
  if Item=nil then exit;
  if FCount>=FHighWaterMark then begin
    SetCapacity(FCapacity*2-1);
  end;
  Index:=IndexOf(Item);
  if Index < 0 then Exit;
  HashItem:=NewHashItem;
  HashItem^.Item:=Item;
  if FItems[Index]=nil then begin
    HashItem^.Next:=FFirstItem;
  end else begin
    HashItem^.Next:=FItems[Index];
    HashItem^.Prior:=HashItem^.Next^.Prior;
    HashItem^.Next^.IsOverflow:=true;
  end;
  if (HashItem^.Next=FFirstItem) then
    FFirstItem:=HashItem;
  FItems[Index]:=HashItem;
  if HashItem^.Next<>nil then begin
    HashItem^.Next^.Prior:=HashItem;
  if HashItem^.Prior<>nil then
    HashItem^.Prior^.Next:=HashItem;
  end;
  inc(FCount);
  SaveCacheItem(Item,Index);
  if FContainsCache<>nil then TRecentList(FContainsCache).Clear;
end;

function TDynHashArray.SlowAlternativeHashMethod(Sender: TDynHashArray;
  Item: Pointer): integer;
begin
  Result:=integer((PtrUInt(Item) mod Cardinal(PrimeNumber))
          +(PtrUInt(Item) mod 17)+(PtrUInt(Item) mod 173)
          +(PtrUInt(Item) mod 521)
           ) mod FCapacity;
end;

procedure TDynHashArray.Remove(Item: Pointer);
begin
  Delete(FindHashItem(Item));
end;

procedure TDynHashArray.Delete(ADynHashArrayItem: PDynHashArrayItem);
var Index: integer;
  OldNext: PDynHashArrayItem;
begin
  if ADynHashArrayItem=nil then exit;
  // delete from cache
  if (FHashCacheIndex>=0)
  and ((ADynHashArrayItem^.Item=FHashCacheItem)
  or (Assigned(OnGetKeyForHashItem)
    and (OnGetKeyForHashItem(ADynHashArrayItem^.Item)=FHashCacheItem)))
  then
    // if the user removes an item, changes the key and readds it, the hash
    // of the item can change
    // => the cache must be cleared
    ClearCache;
  // delete from FItems
  if not ADynHashArrayItem^.IsOverflow then begin
    // Item is first item with hash
    Index:=IndexOf(ADynHashArrayItem^.Item);
    if Index < 0 then Exit; // should not happen
    OldNext:=ADynHashArrayItem^.Next;
    if (OldNext=nil) or (not (OldNext^.IsOverflow)) then
      FItems[Index]:=nil
    else begin
      FItems[Index]:=OldNext;
      OldNext^.IsOverflow:=false;
    end;
  end;
  // adjust FFirstItem
  if FFirstItem=ADynHashArrayItem then
    FFirstItem:=FFirstItem^.Next;
  // free storage item
  DisposeHashItem(ADynHashArrayItem);
  // adjust count and capacity
  dec(FCount);
  if FCount<FLowWaterMark then begin
    // resize
    SetCapacity((FCapacity+1) div 2);
  end;
end;

procedure TDynHashArray.AssignTo(List: TList);
var
  i: integer;
  HashItem: PDynHashArrayItem;
begin
  List.Count:=Count;
  HashItem:=FirstHashItem;
  i:=0;
  while HashItem<>nil do begin
    List[i]:=HashItem^.Item;
    inc(i);
    HashItem:=HashItem^.Next;
  end;
end;

procedure TDynHashArray.AssignTo(List: TFPList);
var
  i: integer;
  HashItem: PDynHashArrayItem;
begin
  List.Count:=Count;
  HashItem:=FirstHashItem;
  i:=0;
  while HashItem<>nil do begin
    List[i]:=HashItem^.Item;
    inc(i);
    HashItem:=HashItem^.Next;
  end;
end;

procedure TDynHashArray.ForEach(const Func: TOnEachHashItem);
var
  HashItem: PDynHashArrayItem;
begin
  HashItem:=FFirstItem;
  while HashItem<>nil do begin
    if not Func(Self,HashItem^.Item) then break;
    HashItem:=HashItem^.Next;
  end;
end;

function TDynHashArray.First: Pointer;
begin
  if FFirstItem<>nil then
    Result:=FFirstItem^.Item
  else
    Result:=nil;
end;

function TDynHashArray.NewHashItem: PDynHashArrayItem;
begin
  Result:=GetItemMemManager.NewItem;
end;

procedure TDynHashArray.DisposeHashItem(ADynHashArrayItem: PDynHashArrayItem);
begin
  GetItemMemManager.DisposeItem(ADynHashArrayItem);
end;

function TDynHashArray.Contains(Item: Pointer): boolean;
begin
  if (FContainsCache=nil) or (not TRecentList(FContainsCache).Contains(Item))
  then begin
    Result:=FindHashItem(Item)<>nil;
    if Result and (FContainsCache<>nil) then
      TRecentList(FContainsCache).Add(Item);
  end else
    Result:=true;
end;

function TDynHashArray.ContainsKey(Key: Pointer): boolean;
begin
  Result:=FindHashItemWithKey(Key)<>nil;
end;

function TDynHashArray.FindHashItem(Item: Pointer): PDynHashArrayItem;
var Index: integer;
begin
  if (Item<>nil) and (FItems<>nil) then begin
    Index:=IndexOf(Item);
    if Index>=0 then begin
      Result:=FItems[Index];
      if (Result<>nil) then begin
        while (Result^.Item<>Item) do begin
          Result:=Result^.Next;
          if Result=nil then exit;
          if Result^.IsOverflow=false then begin
            Result:=nil;
            exit;
          end;
        end;
        SaveCacheItem(Item,Index);
      end;
    end else
      Result:=nil;
  end else
    Result:=nil;
end;

function TDynHashArray.FindHashItemWithKey(Key: Pointer): PDynHashArrayItem;
var Index: integer;
begin
  if FItems<>nil then begin
    Index:=IndexOfKey(Key);
    if Index>=0 then begin
      Result:=FItems[Index];
      if (Result<>nil) then begin
        if Assigned(OnGetKeyForHashItem) then begin
          if OnGetKeyForHashItem(Result^.Item)=Key then exit;
          // search in overflow hash items
          Result:=Result^.Next;
          while (Result<>nil) and (Result^.IsOverflow) do begin
            if OnGetKeyForHashItem(Result^.Item)=Key then begin
              FHashCacheIndex:=Index;
              FHashCacheItem:=Key;
              exit;
            end;
            Result:=Result^.Next;
          end;
          Result:=nil;
        end;
      end;
    end else
      Result:=nil;
  end else
    Result:=nil;
end;

function TDynHashArray.FindItemWithKey(Key: Pointer): Pointer;
var
  Index: integer;
  HashItem: PDynHashArrayItem;
begin
  Result:=nil;
  if FItems<>nil then begin
    Index:=IndexOfKey(Key);
    if Index < 0 then Exit; // should not happen
    HashItem:=FItems[Index];
    if (HashItem<>nil)
    and Assigned(OnGetKeyForHashItem) then begin
      if OnGetKeyForHashItem(HashItem^.Item)=Key then exit;
      // search in overflow hash items
      HashItem:=HashItem^.Next;
      while (HashItem<>nil) and (HashItem^.IsOverflow) do begin
        if OnGetKeyForHashItem(HashItem^.Item)=Key then begin
          FHashCacheIndex:=Index;
          FHashCacheItem:=Key;
          Result:=HashItem^.Item;
          exit;
        end;
        HashItem:=HashItem^.Next;
      end;
    end;
  end;
end;

function TDynHashArray.GetHashItem(HashIndex: integer): PDynHashArrayItem;
begin
  Result:=FItems[HashIndex];
end;

procedure TDynHashArray.SetCapacity(NewCapacity: integer);
var Size: integer;
begin
  if NewCapacity<FMinCapacity then NewCapacity:=FMinCapacity;
  if NewCapacity>FMaxCapacity then NewCapacity:=FMaxCapacity;
  if NewCapacity=FCapacity then exit;
  // resize FItems
  FreeMem(FItems);
  FCapacity:=NewCapacity;
  Size:=FCapacity * SizeOf(PDynHashArrayItem);
  GetMem(FItems,Size);
  ComputeWaterMarks;
  // rebuild
  RebuildItems;
end;

procedure TDynHashArray.SetCustomHashFunction(const AValue: THashFunction);
begin
  if FCustomHashFunction=AValue then exit;
  FCustomHashFunction:=AValue;
  FOwnerHashFunction:=nil;
  RebuildItems;
end;

procedure TDynHashArray.SetOwnerHashFunction(const AValue: TOwnerHashFunction);
begin
  if FOwnerHashFunction=AValue then exit;
  FCustomHashFunction:=nil;
  FOwnerHashFunction:=AValue;
  RebuildItems;
end;

procedure TDynHashArray.RebuildItems;
var Index: integer;
  CurHashItem, NextHashItem: PDynHashArrayItem;
begin
  FillChar(FItems^,FCapacity * SizeOf(PDynHashArrayItem),0);
  ClearCache;
  CurHashItem:=FFirstItem;
  FFirstItem:=nil;
  while CurHashItem<>nil do begin
    NextHashItem:=CurHashItem^.Next;
    Index:=IndexOf(CurHashItem^.Item);
    if Index < 0
    then begin
      // ??? something bad happenend
      // should we dispose current item ?
      // Anyhow, skip it.
      CurHashItem := NextHashItem;
      Continue;
    end;
    CurHashItem^.IsOverFlow:=false;
    CurHashItem^.Prior:=nil;
    if FItems[Index]=nil then begin
      CurHashItem^.Next:=FFirstItem;
    end else begin
      CurHashItem^.Next:=FItems[Index];
      CurHashItem^.Prior:=CurHashItem^.Next^.Prior;
      CurHashItem^.Next^.IsOverflow:=true;
    end;
    if (CurHashItem^.Next=FFirstItem) then
      FFirstItem:=CurHashItem;
    FItems[Index]:=CurHashItem;
    if CurHashItem^.Next<>nil then begin
      CurHashItem^.Next^.Prior:=CurHashItem;
    if CurHashItem^.Prior<>nil then
      CurHashItem^.Prior^.Next:=CurHashItem;
    end;
    CurHashItem:=NextHashItem;
  end;
end;

procedure TDynHashArray.SaveCacheItem(Item: Pointer; Index: integer);
// Important:
//   !!! Only call this method for items, that exists in the list or for items
//       that can't change their key
begin
  if Assigned(OnGetKeyForHashItem) then Item:=OnGetKeyForHashItem(Item);
  FHashCacheItem:=Item;
  FHashCacheIndex:=Index;
end;

constructor TDynHashArray.Create;
begin
  Create(10);
end;

procedure TDynHashArray.SetOnGetKeyForHashItem(
  const AValue: TOnGetKeyForHashItem);
begin
  if FOnGetKeyForHashItem=AValue then exit;
  FOnGetKeyForHashItem:=AValue;
  RebuildItems;
end;

procedure TDynHashArray.SetOptions(const AValue: TDynHashArrayOptions);
begin
  if FOptions=AValue then exit;
  FOptions:=AValue;
  if (FContainsCache<>nil) xor (dhaoCacheContains in Options) then begin
    if FContainsCache=nil then begin
      FContainsCache:=TRecentList.Create(5);
    end else begin
      FContainsCache.Free;
      FContainsCache:=nil;
    end;
  end;
end;

{ TDynHashArrayItemMemManager }

procedure TDynHashArrayItemMemManager.SetMaxFreeRatio(NewValue: integer);
begin
  if NewValue<0 then NewValue:=0;
  if NewValue=FMaxFreeRatio then exit;
  FMaxFreeRatio:=NewValue;
end;

procedure TDynHashArrayItemMemManager.SetMinFree(NewValue: integer);
begin
  if NewValue<0 then NewValue:=0;
  if NewValue=FMinFree then exit;
  FMinFree:=NewValue;
end;

procedure TDynHashArrayItemMemManager.DisposeFirstFreeItem;
var OldItem: PDynHashArrayItem;
begin
  if FFirstFree=nil then exit;
  OldItem:=FFirstFree;
  FFirstFree:=OldItem^.Next;
  if FFirstFree<>nil then
    FFirstFree^.Prior:=nil;
  Dispose(OldItem);
  dec(FFreeCount);
end;

procedure TDynHashArrayItemMemManager.DisposeItem(
  ADynHashArrayItem: PDynHashArrayItem);
begin
  if ADynHashArrayItem=nil then exit;
  // unbind item
  if ADynHashArrayItem^.Next<>nil then
    ADynHashArrayItem^.Next^.Prior:=ADynHashArrayItem^.Prior;
  if ADynHashArrayItem^.Prior<>nil then
    ADynHashArrayItem^.Prior^.Next:=ADynHashArrayItem^.Next;
  // add to free list
  ADynHashArrayItem^.Next:=FFirstFree;
  FFirstFree:=ADynHashArrayItem;
  if ADynHashArrayItem^.Next<>nil then
    ADynHashArrayItem^.Next^.Prior:=ADynHashArrayItem;
  ADynHashArrayItem^.Prior:=nil;
  inc(FFreeCount);
  // reduce free list
  if (FFreeCount>(((8+FMaxFreeRatio)*FCount) shr 3)) and (FFreeCount>10) then
  begin
    DisposeFirstFreeItem;
    DisposeFirstFreeItem;
  end;
end;

function TDynHashArrayItemMemManager.NewItem: PDynHashArrayItem;
begin
  if FFirstFree<>nil then begin
    Result:=FFirstFree;
    FFirstFree:=FFirstFree^.Next;
    if FFirstFree<>nil then
      FFirstFree^.Prior:=nil;
    dec(FFreeCount);
  end else begin
    New(Result);
  end;
  with Result^ do begin
    Item:=nil;
    Next:=nil;
    Prior:=nil;
    IsOverflow:=false;
  end;
end;

procedure TDynHashArrayItemMemManager.Clear;
begin
  while FFreeCount>0 do DisposeFirstFreeItem;
end;

constructor TDynHashArrayItemMemManager.Create;
begin
  inherited Create;
  FFirstFree:=nil;
  FFreeCount:=0;
  FCount:=0;
  FMinFree:=100;
  FMaxFreeRatio:=8; // 1:1
end;

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

function TDynHashArrayItemMemManager.ConsistencyCheck: integer;
var RealFreeCount: integer;
  HashItem: PDynHashArrayItem;
begin
  RealFreeCount:=0;
  HashItem:=FFirstFree;
  while HashItem<>nil do begin
    inc(RealFreeCount);
    if (HashItem^.Next<>nil) and (HashItem^.Next^.Prior<>HashItem) then
      exit(-1);
    if (HashItem^.Prior<>nil) and (HashItem^.Prior^.Next<>HashItem) then
      exit(-2);
    HashItem:=HashItem^.Next;
  end;
  if RealFreeCount<>FFreeCount then exit(-3);
  Result:=0;
end;

procedure TDynHashArrayItemMemManager.WriteDebugReport;
begin
  DebugLn('TDynHashArrayItemMemManager.WriteDebugReport:'
    ,' Consistency=',dbgs(ConsistencyCheck),', FreeCount=',dbgs(FFreeCount));
end;

//==============================================================================

finalization
  FreeAndNil(ItemMemManager);

end.