////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Hash list for fast string indexing.                                        //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20171116 - Creation, first release                                         //
// 20171202 - Uses _HASH library and Hasher.                                  //
// 20171216 - THashListItemRec.Objekt,Objects,KeyedObjects,OwnsObjects.       //
// 20230514 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_hl; // Hash List.

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$WARN 5023 off : Unit "$1" not used in $2}
{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes, math, variants,
 _crw_alloc, _crw_rtc, _crw_str, _crw_hash;

type
 ////////////////////////
 // Hash list item record
 ////////////////////////
 PHashListItemRec = ^THashListItemRec;
 THashListItemRec = packed record // Buffer to store hash list item
  Hash    : Cardinal;             // Hash for fast search
  Data    : Double;               // Data associated
  Link    : Integer;              // Addon data link
  Param   : LongString;           // Addon parameter
  Objekt  : TObject;              // Object instance
  Key     : record end;           // Key is zstring
 end;
 TMemUsedByObjectFunc = function(aObjekt:TObject):Integer;
 //////////////////////////////////////////////////////////////////////
 // THashList uses as assosiative array indexed by string Key to access
 // Data, Link and Para (user Data value, Link & string parameter Para)
 // See TestHashList as example.
 //////////////////////////////////////////////////////////////////////
 THashList = class(TMasterObject)
 private
  myList          : TList;
  myParent        : TObject;
  myHasher        : THash32Function;
  myCollisions    : Cardinal;
  myCaseSensitive : Boolean;
  function    GetCount:Integer;
  function    GetParent:TObject;
  procedure   SetParent(aParent:TObject);
  function    GetHasher:THash32Function;
  function    GetCollisions:Cardinal;
  procedure   SetCollisions(aCollisions:Cardinal);
  function    GetCaseSensitive:Boolean;
  function    GetOwnsObjects:Boolean;
  procedure   SetOwnsObjects(aOwnsObjects:Boolean);
  function    GetItems(aIndex:Integer):PHashListItemRec;
  function    GetHashs(aIndex:Integer):Cardinal;
  function    GetKeys(aIndex:Integer):LongString;
  function    GetDatas(aIndex:Integer):Double;
  procedure   SetDatas(aIndex:Integer; const aData:Double);
  function    GetLinks(aIndex:Integer):Integer;
  procedure   SetLinks(aIndex:Integer; const aLink:Integer);
  function    GetParams(aIndex:Integer):LongString;
  procedure   SetParams(aIndex:Integer; const aParam:LongString);
  function    GetObjects(aIndex:Integer):TObject;
  procedure   SetObjects(aIndex:Integer; const aObjekt:TObject);
  function    GetKeyedItems(aKey:LongString):PHashListItemRec;
  function    GetKeyedHashs(aKey:LongString):Cardinal;
  function    GetKeyedDatas(aKey:LongString):Double;
  procedure   SetKeyedDatas(aKey:LongString; const aData:Double);
  function    GetKeyedLinks(aKey:LongString):Integer;
  procedure   SetKeyedLinks(aKey:LongString; const aLink:Integer);
  function    GetKeyedParams(aKey:LongString):LongString;
  procedure   SetKeyedParams(aKey:LongString; const aParam:LongString);
  function    GetKeyedObjects(aKey:LongString):TObject;
  procedure   SetKeyedObjects(aKey:LongString; const aObjekt:TObject);
 public
  constructor Create(aCaseSensitive:Boolean; aHasher:THash32Function);
  destructor  Destroy; override;
 public
  function    Delete(aKey:PChar):Boolean; overload;
  function    Delete(aKey:LongString):Boolean; overload;
  function    Delete(aIndex:Integer):Boolean; overload;
  function    IndexOf(aKey:PChar):Integer; overload;
  function    IndexOf(aKey:LongString):Integer; overload;
  function    FindItem(aKey:PChar):PHashListItemRec; overload;
  function    FindItem(aKey:LongString):PHashListItemRec; overload;
  function    Search(aKey:PChar; out aIndex:Integer):Boolean; overload;
  function    Search(aKey:LongString; out aIndex:Integer):Boolean; overload;
  function    GetData(aKey:PChar; var aData:Double; var aLink:Integer; var aParam:LongString; var aObjekt:TObject):Boolean; overload;
  function    GetData(aKey:LongString; var aData:Double; var aLink:Integer; var aParam:LongString; var aObjekt:TObject):Boolean; overload;
  function    SetData(aKey:PChar; const aData:Double; const aLink:Integer; const aParam:LongString; const aObjekt:TObject):Boolean; overload;
  function    SetData(aKey:LongString; const aData:Double; const aLink:Integer; const aParam:LongString; const aObjekt:TObject):Boolean; overload;
  function    GetText(aText:TText; aSorted:Boolean):TText; overload;
  function    GetText(aSorted:Boolean):LongString; overload;
  function    MemUsed(aFunc:TMemUsedByObjectFunc=nil):Integer;
  procedure   Clear;
 public
  property    Count:Integer                          read GetCount;
  property    Parent:TObject                         read GetParent write SetParent;
  property    Hasher:THash32Function                 read GetHasher;
  property    Collisions:Cardinal                    read GetCollisions write SetCollisions;
  property    CaseSensitive:Boolean                  read GetCaseSensitive;
  property    OwnsObjects:Boolean                    read GetOwnsObjects write SetOwnsObjects;
 public
  property    Items[aIndex:Integer]:PHashListItemRec read GetItems; default;
  property    Hashs[aIndex:Integer]:Cardinal         read GetHashs;
  property    Keys[aIndex:Integer]:LongString        read GetKeys;
  property    Datas[aIndex:Integer]:Double           read GetDatas   write SetDatas;
  property    Links[aIndex:Integer]:Integer          read GetLinks   write SetLinks;
  property    Params[aIndex:Integer]:LongString      read GetParams  write SetParams;
  property    Objects[aIndex:Integer]:TObject        read GetObjects write SetObjects;
 public
  property    KeyedItems[aKey:LongString]:PHashListItemRec read GetKeyedItems;
  property    KeyedHashs[aKey:LongString]:Cardinal         read GetKeyedHashs;
  property    KeyedDatas[aKey:LongString]:Double           read GetKeyedDatas   write SetKeyedDatas;
  property    KeyedLinks[aKey:LongString]:Integer          read GetKeyedLinks   write SetKeyedLinks;
  property    KeyedParams[aKey:LongString]:LongString      read GetKeyedParams  write SetKeyedParams;
  property    KeyedObjects[aKey:LongString]:TObject        read GetKeyedObjects write SetKeyedObjects;
 end;

function NewHashList(aCaseSensitive:Boolean; aHasher:THash32Function):THashList;
procedure Kill(var TheObject:THashList); overload;

const HashList_NumCollisions : Int64 = 0;
const HashList_DefaultHasher : THash32Function = Hash32_RS;

 ///////////////////////////////
 // DaqPascal oriented interface
 ///////////////////////////////
function HashList_Init(aCaseSensitive:Boolean; aHasher:THash32Function):Integer;
function HashList_Free(aRef:Integer):Boolean;
function HashList_Ref(aRef:Integer):THashList;
function HashList_Count(aRef:Integer):Integer;
function HashList_GetKey(aRef:Integer; aIndex:Integer):LongString;
function HashList_Delete(aRef:Integer; aKey:LongString):Boolean;
function HashList_IndexOf(aRef:Integer; aKey:LongString):Integer;
function HashList_GetData(aRef:Integer; aKey:LongString):Double;
function HashList_SetData(aRef:Integer; aKey:LongString; aData:Double):Boolean;
function HashList_GetLink(aRef:Integer; aKey:LongString):Integer;
function HashList_SetLink(aRef:Integer; aKey:LongString; aLink:Integer):Boolean;
function HashList_GetPara(aRef:Integer; aKey:LongString):LongString;
function HashList_SetPara(aRef:Integer; aKey:LongString; aParam:LongString):Boolean;
function HashList_ValidateHasher(aHasher:THash32Function):THash32Function;

 ////////////////////////////////////////////////
 // Test HashList functionality and usage example
 ////////////////////////////////////////////////
function TestHashList(aMaxIter:Integer; aHasher:THash32Function):Boolean;
function TestHashListLeak(aMaxIter:Integer; aHasher:THash32Function):Boolean;

implementation

 ////////////////////
 // Internal routines
 ////////////////////

function StrOk(Str:PChar):Boolean;
begin
 if Assigned(Str) then Result:=(Str[0]<>#0) else Result:=false;
end;

function SortText(const aText:LongString):LongString;
var List:TStringList;
begin
 Result:='';
 try
  List:=TStringList.Create;
  try
   List.Text:=aText;
   List.Sort;
   Result:=List.Text;
  finally
   Kill(List);
  end;
 except
  on E:Exception do BugReport(E,nil,'SortText');
 end;
end;

 //////////////////////////////////////////
 // Internal list of buffers for THashList.
 //////////////////////////////////////////
type
 THashBufferList = class(TList)
 private
  FOwnsObjects: Boolean;
 protected
  procedure Notify(Ptr:Pointer; Action:TListNotification); override;
 public
  constructor Create(AOwnsObjects: Boolean);
  property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;
 end;

 /////////////////////////////////
 // THashBufferList implementation
 /////////////////////////////////
constructor THashBufferList.Create(AOwnsObjects: Boolean);
begin
 inherited Create;
 FOwnsObjects := AOwnsObjects;
end;

procedure THashBufferList.Notify(Ptr: Pointer; Action: TListNotification);
begin
 if (Action=lnDeleted) then
 try
  if Assigned(Ptr) then
  with PHashListItemRec(Ptr)^ do begin
   if Assigned(Objekt) and OwnsObjects then Kill(Objekt);
   Data:=0; Link:=0; Param:='';
  end;
  Deallocate(Ptr);
 except
  on E:Exception do BugReport(E,Self,'Notify');
 end;
 inherited Notify(Ptr,Action);
end;

procedure Kill(var TheObject:THashBufferList); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end;
end;

 //////////////////////////////////
 // THashListItemRec implementation
 //////////////////////////////////
function NewHashListItemRec(aKey:PChar; const aData:Double; const aLink:Integer; const aParam:LongString; const aObjekt:TObject;
                            aCaseSensitive:Boolean; aHasher:THash32Function):PHashListItemRec;
var KeyLen:Integer;
begin
 Result:=nil;
 try
  KeyLen:=StrLen(aKey);
  if (KeyLen>0)
  then Result:=Allocate(sizeof(Result^)+KeyLen+1);
  if Assigned(Result) then begin
   Result.Hash:=0;
   Result.Data:=aData;
   Result.Link:=aLink;
   Result.Param:=aParam;
   Result.Objekt:=aObjekt;
   StrLCopy(PChar(@Result.Key),aKey,KeyLen);
   if not aCaseSensitive then StrLower(PChar(@Result.Key));
   if Assigned(aHasher) then Result.Hash:=aHasher(PChar(@Result.Key),KeyLen);
  end;
 except
  on E:Exception do BugReport(E,nil,'NewHashListItemRec');
 end;
end;

 //
 // THashList implementation
 //
constructor THashList.Create(aCaseSensitive:Boolean; aHasher:THash32Function);
begin
 inherited Create;
 Exceptions:=false;
 myList:=THashBufferList.Create(true);
 myCaseSensitive:=aCaseSensitive;
 myHasher:=aHasher;
 myParent:=nil;
end;

destructor THashList.Destroy;
begin
 Clear;
 Kill(myList);
 inherited Destroy;
end;

function THashList.GetCount:Integer;
begin
 if Assigned(Self) then Result:=myList.Count else Result:=0;
end;

function THashList.GetParent:TObject;
begin
 if Assigned(Self) then Result:=myParent else Result:=nil;
end;

procedure THashList.SetParent(aParent:TObject);
begin
 if Assigned(Self) then myParent:=aParent;
end;

function THashList.GetHasher:THash32Function;
begin
 if Assigned(Self) then Result:=myHasher else Result:=nil;
end;

function THashList.GetCollisions:Cardinal;
begin
 if Assigned(Self) then Result:=myCollisions else Result:=0;
end;

procedure THashList.SetCollisions(aCollisions:Cardinal);
begin
 if Assigned(Self) then myCollisions:=aCollisions;
end;

function THashList.GetCaseSensitive:Boolean;
begin
 if Assigned(Self) then Result:=myCaseSensitive else Result:=false;
end;

function THashList.GetOwnsObjects:Boolean;
begin
 if Assigned(Self) and (myList is THashBufferList)
 then Result:=THashBufferList(myList).OwnsObjects
 else Result:=false;
end;

procedure THashList.SetOwnsObjects(aOwnsObjects:Boolean);
begin
 if Assigned(Self) and (myList is THashBufferList)
 then THashBufferList(myList).OwnsObjects:=aOwnsObjects;
end;

function THashList.GetItems(aIndex:Integer):PHashListItemRec;
var Item:PHashListItemRec;
begin
 if Assigned(Self) and ((aIndex>=0) and (aIndex<myList.Count))
 then Item:=myList.List[aIndex]
 else Item:=nil;
 Result:=Item;
end;

function THashList.GetHashs(aIndex:Integer):Cardinal;
var Item:PHashListItemRec;
begin
 if Assigned(Self) and ((aIndex>=0) and (aIndex<myList.Count))
 then Item:=myList.List[aIndex]
 else Item:=nil;
 if Assigned(Item)
 then Result:=Item.Hash
 else Result:=0;
end;

function THashList.GetKeys(aIndex:Integer):LongString;
var Item:PHashListItemRec;
begin
 if Assigned(Self) and ((aIndex>=0) and (aIndex<myList.Count))
 then Item:=myList.List[aIndex]
 else Item:=nil;
 if Assigned(Item)
 then Result:=PChar(@Item.Key)
 else Result:='';
end;

function THashList.GetDatas(aIndex:Integer):Double;
var Item:PHashListItemRec;
begin
 if Assigned(Self) and ((aIndex>=0) and (aIndex<myList.Count))
 then Item:=myList.List[aIndex]
 else Item:=nil;
 if Assigned(Item)
 then Result:=Item.Data
 else Result:=0;
end;

procedure THashList.SetDatas(aIndex:Integer; const aData:Double);
var Item:PHashListItemRec;
begin
 if Assigned(Self) and ((aIndex>=0) and (aIndex<myList.Count))
 then Item:=myList.List[aIndex]
 else Item:=nil;
 if Assigned(Item)
 then Item.Data:=aData;
end;

function THashList.GetLinks(aIndex:Integer):Integer;
var Item:PHashListItemRec;
begin
 if Assigned(Self) and ((aIndex>=0) and (aIndex<myList.Count))
 then Item:=myList.List[aIndex]
 else Item:=nil;
 if Assigned(Item)
 then Result:=Item.Link
 else Result:=0;
end;

procedure THashList.SetLinks(aIndex:Integer; const aLink:Integer);
var Item:PHashListItemRec;
begin
 if Assigned(Self) and ((aIndex>=0) and (aIndex<myList.Count))
 then Item:=myList.List[aIndex]
 else Item:=nil;
 if Assigned(Item)
 then Item.Link:=aLink;
end;

function THashList.GetParams(aIndex:Integer):LongString;
var Item:PHashListItemRec;
begin
 if Assigned(Self) and ((aIndex>=0) and (aIndex<myList.Count))
 then Item:=myList.List[aIndex]
 else Item:=nil;
 if Assigned(Item)
 then Result:=Item.Param
 else Result:='';
end;

procedure THashList.SetParams(aIndex:Integer; const aParam:LongString);
var Item:PHashListItemRec;
begin
 if Assigned(Self) and ((aIndex>=0) and (aIndex<myList.Count))
 then Item:=myList.List[aIndex]
 else Item:=nil;
 if Assigned(Item)
 then Item.Param:=aParam;
end;

function THashList.GetObjects(aIndex:Integer):TObject;
var Item:PHashListItemRec;
begin
 if Assigned(Self) and ((aIndex>=0) and (aIndex<myList.Count))
 then Item:=myList.List[aIndex]
 else Item:=nil;
 if Assigned(Item)
 then Result:=Item.Objekt
 else Result:=nil;
end;

procedure THashList.SetObjects(aIndex:Integer; const aObjekt:TObject);
var Item:PHashListItemRec;
begin
 if Assigned(Self) and ((aIndex>=0) and (aIndex<myList.Count))
 then Item:=myList.List[aIndex]
 else Item:=nil;
 if Assigned(Item) then begin
  if Assigned(Item.Objekt) and (Item.Objekt<>aObjekt) and OwnsObjects then Kill(Item.Objekt);
  Item.Objekt:=aObjekt;
 end;
end;

function THashList.Search(aKey:PChar; out aIndex:Integer):Boolean;
var Left,Right,Middle,Comparison,KeyLen:Integer; ItemList:PPointerList;
    MiddleItem:PHashListItemRec; MiddleKey:PChar; aHash:Cardinal;
    KeyBuf:PChar; KeyBuffer:TMaxPathBuffer; KeyLong:LongString;
begin
 Left:=0;
 Result:=False;
 if Assigned(Self) then
 if Assigned(aKey) then
 if (aKey[0]<>#0) then begin
  KeyLen:=StrLen(aKey);
  if myCaseSensitive then KeyBuf:=aKey else begin
   if (KeyLen<sizeof(KeyBuffer)) then begin
    KeyBuf:=StrLCopy(KeyBuffer,aKey,KeyLen);
   end else begin
    SetString(KeyLong,aKey,KeyLen);
    KeyBuf:=PChar(KeyLong);
   end;
   StrLower(KeyBuf);
  end;
  if Assigned(myHasher)
  then aHash:=myHasher(KeyBuf,KeyLen)
  else aHash:=0;
  ItemList:=myList.List;
  Right:=myList.Count-1;
  while Left<=Right do begin
   Middle:=(Left+Right) shr 1;
   MiddleItem:=ItemList[Middle];
   if Assigned(myHasher) and Assigned(MiddleItem) then begin
    if MiddleItem.Hash>aHash then Comparison:=+1 else
    if MiddleItem.Hash<aHash then Comparison:=-1 else Comparison:=0;
   end else Comparison:=0;
   if Comparison=0 then begin
    if Assigned(MiddleItem)
    then MiddleKey:=PChar(@MiddleItem.Key)
    else MiddleKey:=nil;
    Comparison:=StrComp(MiddleKey,KeyBuf);
    if (Comparison<>0) and Assigned(myHasher) then begin
     Inc(HashList_NumCollisions);
     Inc(myCollisions);
    end;
   end;
   if Comparison<0 then Left:=Middle+1 else begin
    Right:=Middle-1;
    if Comparison=0 then begin
     Result:=True;
     Left:=Middle;
    end;
   end;
  end;
 end;
 aIndex:=Left;
end;
function THashList.Search(aKey:LongString; out aIndex:Integer):Boolean;
begin
 Result:=Search(PChar(aKey),aIndex);
end;

function THashList.IndexOf(aKey:PChar):Integer;
begin
 Result:=-1;
 if not Search(aKey,Result) then Result:=-1;
end;
function THashList.IndexOf(aKey:LongString):Integer;
begin
 Result:=IndexOf(PChar(aKey));
end;

function THashList.FindItem(aKey:PChar):PHashListItemRec;
var aIndex:Integer;
begin
 if Search(aKey,aIndex) then Result:=Items[aIndex] else Result:=nil;
end;
function THashList.FindItem(aKey:LongString):PHashListItemRec;
begin
 Result:=FindItem(PChar(aKey));
end;

function THashList.Delete(aIndex:Integer):Boolean;
begin
 if Assigned(Self) and ((aIndex>=0) and (aIndex<myList.Count)) then begin
  myList.Delete(aIndex);
  Result:=true;
 end else Result:=false;
end;
function THashList.Delete(aKey:PChar):Boolean;
var aIndex:Integer;
begin
 if Search(aKey,aIndex) then begin
  myList.Delete(aIndex);
  Result:=true;
 end else Result:=false;
end;
function THashList.Delete(aKey:LongString):Boolean;
begin
 Result:=Delete(PChar(aKey));
end;

function THashList.GetData(aKey:PChar; var aData:Double; var aLink:Integer; var aParam:LongString; var aObjekt:TObject):Boolean;
var aIndex:Integer;
begin
 if Search(aKey,aIndex) then begin
  aData:=Datas[aIndex];
  aLink:=Links[aIndex];
  aParam:=Params[aIndex];
  aObjekt:=Objects[aIndex];
  Result:=true;
 end else begin
  aData:=0;
  aLink:=0;
  aParam:='';
  aObjekt:=nil;
  Result:=false;
 end;
end;
function THashList.GetData(aKey:LongString; var aData:Double; var aLink:Integer; var aParam:LongString; var aObjekt:TObject):Boolean;
begin
 Result:=GetData(PChar(aKey),aData,aLink,aParam,aObjekt);
end;

function THashList.SetData(aKey:PChar; const aData:Double; const aLink:Integer; const aParam:LongString; const aObjekt:TObject):Boolean;
var aIndex:Integer; aItem:PHashListItemRec;
begin
 Result:=false;
 if Search(aKey,aIndex) then begin
  Datas[aIndex]:=aData;
  Links[aIndex]:=aLink;
  Params[aIndex]:=aParam;
  Objects[aIndex]:=aObjekt;
  Result:=true;
 end else if Assigned(Self) and StrOk(aKey) then
 try
  aItem:=NewHashListItemRec(aKey,aData,aLink,aParam,aObjekt,myCaseSensitive,myHasher);
  if Assigned(aItem) then myList.Insert(aIndex,aItem);
  Result:=Assigned(aItem);
 except
  on E:Exception do ErrorReport(E);
 end;
end;
function THashList.SetData(aKey:LongString; const aData:Double; const aLink:Integer; const aParam:LongString; const aObjekt:TObject):Boolean;
begin
 Result:=SetData(PChar(aKey),aData,aLink,aParam,aObjekt);
end;

function THashList.GetKeyedItems(aKey:LongString):PHashListItemRec;
var aIndex:Integer;
begin
 if Search(PChar(aKey),aIndex) then Result:=Items[aIndex] else Result:=nil;
end;

function THashList.GetKeyedHashs(aKey:LongString):Cardinal;
var aIndex:Integer;
begin
 if Search(PChar(aKey),aIndex) then Result:=Hashs[aIndex] else Result:=0;
end;

function THashList.GetKeyedDatas(aKey:LongString):Double;
var aIndex:Integer;
begin
 if Search(PChar(aKey),aIndex) then Result:=Datas[aIndex] else Result:=0;
end;

procedure THashList.SetKeyedDatas(aKey:LongString; const aData:Double);
var aIndex:Integer;
begin
 if Search(PChar(aKey),aIndex) then Datas[aIndex]:=aData else SetData(PChar(aKey),aData,0,'',nil);
end;

function THashList.GetKeyedLinks(aKey:LongString):Integer;
var aIndex:Integer;
begin
 if Search(PChar(aKey),aIndex) then Result:=Links[aIndex] else Result:=0;
end;

procedure THashList.SetKeyedLinks(aKey:LongString; const aLink:Integer);
var aIndex:Integer;
begin
 if Search(PChar(aKey),aIndex) then Links[aIndex]:=aLink else SetData(PChar(aKey),0,aLink,'',nil);
end;

function THashList.GetKeyedParams(aKey:LongString):LongString;
var aIndex:Integer;
begin
 if Search(PChar(aKey),aIndex) then Result:=Params[aIndex] else Result:='';
end;

procedure THashList.SetKeyedParams(aKey:LongString; const aParam:LongString);
var aIndex:Integer;
begin
 if Search(PChar(aKey),aIndex) then Params[aIndex]:=aParam else SetData(PChar(aKey),0,0,aParam,nil);
end;

function THashList.GetKeyedObjects(aKey:LongString):TObject;
var aIndex:Integer;
begin
 if Search(PChar(aKey),aIndex) then Result:=Objects[aIndex] else Result:=nil;
end;

procedure THashList.SetKeyedObjects(aKey:LongString; const aObjekt:TObject);
var aIndex:Integer;
begin
 if Search(PChar(aKey),aIndex) then Objects[aIndex]:=aObjekt else SetData(PChar(aKey),0,0,'',aObjekt);
end;

function THashList.GetText(aText:TText; aSorted:Boolean):TText;
var MaxLen,i:Integer; List:TText;
begin
 Result:=aText;
 if Assigned(Self) and Assigned(aText) then
 try
  List:=NewText;
  try
   MaxLen:=0;
   for i:=0 to Count-1 do MaxLen:=math.max(MaxLen,Length(Keys[i]));
   for i:=0 to Count-1 do List.Addln(Format('%-*s = %s, %s, %s',[MaxLen,Keys[i],VarToStr(Datas[i]),VarToStr(Links[i]),VarToStr(Params[i])]));
   if aSorted then List.Text:=SortText(List.Text);
   aText.Concat(List);
  finally
   Kill(List);
  end;
 except
  on E:Exception do BugReport(E,Self,'GetText');
 end;
end;
function THashList.GetText(aSorted:Boolean):LongString;
var List:TText;
begin
 Result:='';
 if Assigned(Self) then
 try
  List:=GetText(NewText,aSorted);
  try
   Result:=List.Text;
  finally
   Kill(List);
  end;
 except
  on E:Exception do BugReport(E,Self,'GetText');
 end;
end;

function THashList.MemUsed(aFunc:TMemUsedByObjectFunc=nil):Integer;
var i:Integer; Item:PHashListItemRec;
begin
 Result:=0;
 if Assigned(Self) then
 try
  for i:=0 to Count-1 do begin
   Item:=Items[i];
   if Assigned(Item) then begin
    inc(Result,AllocSize(Item));
    inc(Result,Length(Item.Param));
    if Assigned(aFunc) and Assigned(Item.Objekt)
    then inc(Result,aFunc(Item.Objekt));
   end;
  end;
 except
  on E:Exception do BugReport(E,Self,'MemUsed');
 end;
end;

procedure THashList.Clear;
begin
 if Assigned(Self) then myList.Clear;
end;

function NewHashList(aCaseSensitive:Boolean; aHasher:THash32Function):THashList;
begin
 Result:=nil;
 try
  Result:=THashList.Create(aCaseSensitive,aHasher);
 except
  on E:Exception do BugReport(E,nil,'NewHashList');
 end;
end;

procedure Kill(var TheObject:THashList); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end;
end;

 ///////////////////////////////
 // DaqPascal oriented interface
 ///////////////////////////////
function HashList_Init(aCaseSensitive:Boolean; aHasher:THash32Function):Integer;
begin
 Result:=NewHashList(aCaseSensitive,aHasher).Ref;
end;

function HashList_Free(aRef:Integer):Boolean;
var hl:THashList;
begin
 Result:=false;
 if aRef<>0 then
 try
  TObject(hl):=ObjectRegistry[aRef];
  if TObject(hl) is THashList then begin
   Result:=true;
   Kill(hl);
  end;
 except
  on E:Exception do BugReport(E,nil,'HashList_Free');
 end;
end;

function HashList_Ref(aRef:Integer):THashList;
var hl:THashList;
begin
 Result:=nil;
 if aRef<>0 then
 try
  TObject(hl):=ObjectRegistry[aRef];
  if TObject(hl) is THashList then Result:=hl;
 except
  on E:Exception do BugReport(E,nil,'HashList_Ref');
 end;
end;

function HashList_Count(aRef:Integer):Integer;
var hl:THashList;
begin
 Result:=0;
 if aRef<>0 then
 try
  TObject(hl):=ObjectRegistry[aRef];
  if TObject(hl) is THashList then begin
   Result:=hl.Count;
  end;
 except
  on E:Exception do BugReport(E,nil,'HashList_Count');
 end;
end;

function HashList_GetKey(aRef:Integer; aIndex:Integer):LongString;
var hl:THashList;
begin
 Result:='';
 if aRef<>0 then
 try
  TObject(hl):=ObjectRegistry[aRef];
  if TObject(hl) is THashList then begin
   Result:=hl.Keys[aIndex];
  end;
 except
  on E:Exception do BugReport(E,nil,'HashList_GetKey');
 end;
end;

function HashList_Delete(aRef:Integer; aKey:LongString):Boolean;
var hl:THashList;
begin
 Result:=false;
 if aRef<>0 then
 try
  TObject(hl):=ObjectRegistry[aRef];
  if TObject(hl) is THashList then begin
   Result:=hl.Delete(aKey);
  end;
 except
  on E:Exception do BugReport(E,nil,'HashList_Delete');
 end;
end;

function HashList_IndexOf(aRef:Integer; aKey:LongString):Integer;
var hl:THashList;
begin
 Result:=-1;
 if aRef<>0 then
 if aKey<>'' then
 try
  TObject(hl):=ObjectRegistry[aRef];
  if TObject(hl) is THashList then begin
   Result:=hl.IndexOf(aKey);
  end;
 except
  on E:Exception do BugReport(E,nil,'HashList_IndexOf');
 end;
end;

function HashList_GetData(aRef:Integer; aKey:LongString):Double;
var hl:THashList;
begin
 Result:=0;
 if aRef<>0 then
 if aKey<>'' then
 try
  TObject(hl):=ObjectRegistry[aRef];
  if TObject(hl) is THashList then begin
   Result:=hl.KeyedDatas[aKey];
  end;
 except
  on E:Exception do BugReport(E,nil,'HashList_GetData');
 end;
end;

function HashList_SetData(aRef:Integer; aKey:LongString; aData:Double):Boolean;
var hl:THashList;
begin
 Result:=false;
 if aRef<>0 then
 if aKey<>'' then
 try
  TObject(hl):=ObjectRegistry[aRef];
  if TObject(hl) is THashList then begin
   hl.KeyedDatas[aKey]:=aData;
   Result:=true;
  end;
 except
  on E:Exception do BugReport(E,nil,'HashList_SetData');
 end;
end;

function HashList_GetLink(aRef:Integer; aKey:LongString):Integer;
var hl:THashList;
begin
 Result:=0;
 if aRef<>0 then
 if aKey<>'' then
 try
  TObject(hl):=ObjectRegistry[aRef];
  if TObject(hl) is THashList then begin
   Result:=hl.KeyedLinks[aKey];
  end;
 except
  on E:Exception do BugReport(E,nil,'HashList_GetLink');
 end;
end;

function HashList_SetLink(aRef:Integer; aKey:LongString; aLink:Integer):Boolean;
var hl:THashList;
begin
 Result:=false;
 if aRef<>0 then
 if aKey<>'' then
 try
  TObject(hl):=ObjectRegistry[aRef];
  if TObject(hl) is THashList then begin
   hl.KeyedLinks[aKey]:=aLink;
   Result:=true;
  end;
 except
  on E:Exception do BugReport(E,nil,'HashList_SetLink');
 end;
end;

function HashList_GetPara(aRef:Integer; aKey:LongString):LongString;
var hl:THashList;
begin
 Result:='';
 if aRef<>0 then
 if aKey<>'' then
 try
  TObject(hl):=ObjectRegistry[aRef];
  if TObject(hl) is THashList then begin
   Result:=hl.KeyedParams[aKey];
  end;
 except
  on E:Exception do BugReport(E,nil,'HashList_GetPara');
 end;
end;

function HashList_SetPara(aRef:Integer; aKey:LongString; aParam:LongString):Boolean;
var hl:THashList;
begin
 Result:=false;
 if aRef<>0 then
 if aKey<>'' then
 try
  TObject(hl):=ObjectRegistry[aRef];
  if TObject(hl) is THashList then begin
   hl.KeyedParams[aKey]:=aParam;
   Result:=true;
  end;
 except
  on E:Exception do BugReport(E,nil,'HashList_SetPara');
 end;
end;

function HashList_ValidateHasher(aHasher:THash32Function):THash32Function;
begin
 Result:=aHasher;
 if not Assigned(Result) then Result:=HashList_DefaultHasher;
 if not Assigned(Result) then Result:=Hash32FuncTable[0].Func;
 if not Assigned(Result) then Result:=Hash32_RS;
end;

 //
 // Test and example of THashList usage.
 //
function TestHashList(aMaxIter:Integer; aHasher:THash32Function):Boolean;
var hl:THashList; i,n,k,m:Integer; si,s:LongString; d:Double; ms:Int64;
begin
 Result:=false;
 try
  hl:=NewHashList(false,aHasher);
  try
   for i:=1 to aMaxIter do begin
    si:=Format('Data_%.5d',[i]);
    if i<(aMaxIter div 2) then begin
     hl.SetData(si,+i,-i,IntToStr(2*i),nil);
    end else begin
     hl.KeyedDatas[si]:=+i;
     hl.KeyedLinks[si]:=-i;
     hl.KeyedParams[si]:=IntToStr(2*i);
    end;
   end;
   //writeln('Sorted:'); write(hl.GetText(true));
   //writeln('Origin:'); write(hl.GetText(false));
   n:=0;
   for i:=1 to aMaxIter do begin
    si:=Format('Data_%.5d',[i]);
    d:=hl.KeyedDatas[si]; if d<>+i then inc(n);
    k:=hl.KeyedLinks[si]; if k<>-i then inc(n);
    s:=hl.KeyedParams[si]; if s<>IntToStr(2*i) then inc(n);
   end;
   writeln(Format('%d error(s) found',[n]));
   writeln(Format('%d collision(s)',[hl.Collisions]));
   ms:=GetTickCount64; n:=0; m:=0;
   while (GetTickCount64-ms<1000) do begin
    i:=random(hl.Count);
    si:=Format('Data_%.5d',[i]);
    for k:=1 to 1000 do begin
     Inc(m,hl.KeyedLinks[si]);
     Inc(n);
    end;
   end;
   ms:=GetTickCount64-ms;
   writeln(Format('Hash.Count %d, made %d calls in %d ms',[hl.Count,n,ms]));
   writeln(Format('Hash keyed access %.4g mks/call',[ms*1e3/n]));
  finally
   Kill(hl);
  end;
  Result:=true;
 except
  on E:Exception do BugReport(E,nil,'TestHashList');
 end;
end;

function TestHashListLeak(aMaxIter:Integer; aHasher:THash32Function):Boolean;
var mem:Integer;
begin
 writeln('TestHashList:');
 mem:=GetAllocMemSize;
 Result:=TestHashList(aMaxIter,aHasher);
 mem:=GetAllocMemSize-mem;
 writeln(Result,' leak ',mem);
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_hl;
begin
end;

procedure Free_crw_hl;
begin
 ResourceLeakageLog(Format('%-60s = %d',['HashList Collisions',HashList_NumCollisions]));
end;

initialization

 Init_crw_hl;

finalization

 Free_crw_hl;

end.

//////////////
// END OF FILE
//////////////

