{
	THashTable unit - Delphi 1 version
     by kktos, May 1997.
     This code is FREEWARE.
     *** Please, if you enhance it, mail me at kktos@sirius.fr ***
}
unit HashTabl;

interface

uses Classes;

type
	TDeleteType= (dtDelete, dtDetach);

{ Class THashList, from Delphi 2 TList source
	used internally, but you can use it for any purpose
}

	THashItem= record
		key:	longint;
	     obj:	TObject;
	end;

	PHashItemList = ^THashItemList;
     THashItemList = array[0..0] of THashItem;

     THashList = class(TObject)
     private
        	Flist:		PHashItemList;
        	Fcount: 		integer;
		Fcapacity:	integer;
          memSize:		longint;
          FdeleteType:	TDeleteType;

     protected
        	procedure Error;
        	function Get(Index: Integer): THashItem;
        	procedure Grow;
        	procedure Put(Index: Integer; const Item: THashItem);
        	procedure SetCapacity(NewCapacity: Integer);
       	procedure SetCount(NewCount: Integer);

     public
  		constructor Create;
        	destructor Destroy; override;

        	function Add(const Item: THashItem): Integer;
        	procedure Clear(dt: TDeleteType);
        	procedure Detach(Index: Integer);
        	procedure Delete(Index: Integer);
        	function Expand: THashList;
        	function IndexOf(key: longint): Integer;
        	procedure Pack;

        	property DeleteType: TDeleteType			read FdeleteType	write FdeleteType;
        	property Capacity: Integer				read FCapacity		write SetCapacity;
        	property Count: Integer					read FCount		write SetCount;
		property Items[Index: Integer]: THashItem	read Get			write Put; 	default;
     end;

{ Class THashTable
	the real hashtable.
}

  THashTable= class(TObject)
  private
		Ftable:	THashList;

		procedure Error;

		function getCount: integer;
          procedure setCount(count: integer);
		function getCapacity: integer;
          procedure setCapacity(capacity: integer);
		function getItem(index: integer): TObject;
          procedure setItem(index: integer; obj: TObject);
		function getDeleteType: TDeleteType;
          procedure setDeleteType(dt: TDeleteType);

  public
  		constructor Create;
  		destructor Destroy; override;

		procedure Add(const key: string; value: TObject);
     	function Get(const key: string): TObject;
     	procedure Detach(const key: string);
     	procedure Delete(const key: string);
        	procedure Clear(dt: TDeleteType);
    		procedure Pack;

        	property DeleteType: TDeleteType			read getDeleteType	write setDeleteType;
	   	property Count: integer 					read getCount		write setCount;
        	property Capacity: Integer				read getCapacity	write setCapacity;
        	property Items[index: Integer]: TObject		read getItem		write setItem;
          property Table: THashList				read Ftable;
  end;

function hash(key: Pointer; length: longint; level: longint): longint; 

implementation

uses SysUtils, Consts;

type
	longArray=	packed array[0..3] of byte;
	longArrayPtr=	^longArray;

	array12=		packed array[0..11] of byte;
	array12Ptr=	^array12;

     longPtr=		^longint;


{ --- Class THashList ---
	brute copy of TList D2 source, with some minors changes
     no comment, see TList
}

{-----------------------------------------------------------------------------}
constructor THashList.Create;
begin
	FdeleteType:= dtDelete;
	FCapacity:= 0;
     FCount:= 0;
     memSize:= 4;
     Flist:= AllocMem(memSize);
     SetCapacity(100);
end;

{-----------------------------------------------------------------------------}
destructor THashList.Destroy;
begin
	Clear(FdeleteType);
     FreeMem(FList, memSize);
end;

{-----------------------------------------------------------------------------}
function THashList.Add(const Item: THashItem): Integer;
begin
	Result := FCount;
	if(Result = FCapacity) then Grow;
	FList^[Result].key:= Item.key;
	FList^[Result].obj:= Item.obj;
	Inc(FCount);
end;

{-----------------------------------------------------------------------------}
procedure THashList.Clear(dt: TDeleteType);
var
	i:	integer;
begin
	if(dt=dtDelete) then
		for i := FCount - 1 downto 0 do
		  	if(Items[i].obj <> nil) then
     			Items[i].obj.Free;
     {FreeMem(FList, memSize);
     memSize:= 4;
     Flist:= AllocMem(memSize);}
	FCapacity:= 0;
     FCount:= 0;
end;

{-----------------------------------------------------------------------------}
{ know BC++ ? remember TArray::Detach?
	if not, Detach remove the item from the list without disposing the object
}
procedure THashList.Detach(Index: Integer);
begin
	if((Index < 0) or (Index >= FCount)) then Error;
	Dec(FCount);
	if(Index < FCount) then
		System.Move(FList^[Index + 1], FList^[Index], (FCount - Index) * SizeOf(THashItem));
end;

{-----------------------------------------------------------------------------}
{ know BC++ ? remember TArray::Destroy ? renames delete 'cause destroy...
	if not, Delete remove the item from the list AND dispose the object
}
procedure THashList.Delete(Index: Integer);
begin
	if((Index < 0) or (Index >= FCount)) then Error;
	Dec(FCount);
	if(Index < FCount) then begin
		FList^[Index].obj.Free;
		System.Move(FList^[Index + 1], FList^[Index], (FCount - Index) * SizeOf(THashItem));
     end;
end;

{-----------------------------------------------------------------------------}
procedure THashList.Error;
begin
	raise EListError.CreateRes(SListIndexError);
end;

{-----------------------------------------------------------------------------}
function THashList.Expand: THashList;
begin
	if(FCount = FCapacity) then Grow;
	Result:= Self;
end;

{-----------------------------------------------------------------------------}
function THashList.Get(Index: Integer): THashItem;
begin
	if((Index < 0) or (Index >= FCount)) then Error;
	Result.key:= FList^[Index].key;
	Result.obj:= FList^[Index].obj;
end;

{-----------------------------------------------------------------------------}
procedure THashList.Grow;
var
  Delta: Integer;
begin
	if FCapacity > 8 then Delta := 16
     else	if FCapacity > 4 then Delta := 8
     else	Delta := 4;
	SetCapacity(FCapacity + Delta);
end;

{-----------------------------------------------------------------------------}
function THashList.IndexOf(key: longint): Integer;
begin
	Result := 0;
	while (Result < FCount) and (FList^[Result].key <> key) do Inc(Result);
	if Result = FCount then Result:= -1;
end;

{-----------------------------------------------------------------------------}
procedure THashList.Put(Index: Integer; const Item: THashItem);
begin
	if (Index < 0) or (Index >= FCount) then Error;
	FList^[Index].key:= Item.key;
	FList^[Index].obj:= Item.obj;
end;

{-----------------------------------------------------------------------------}
procedure THashList.Pack;
var
  i: Integer;
begin
	for i := FCount - 1 downto 0 do
	  	if Items[i].obj = nil then Delete(i);
end;

{-----------------------------------------------------------------------------}
procedure THashList.SetCapacity(NewCapacity: Integer);
begin
	if((NewCapacity < FCount) or (NewCapacity > MaxListSize)) then Error;
	if(NewCapacity <> FCapacity) then begin
		FList:= ReallocMem(FList, memSize, NewCapacity * SizeOf(THashItem));
     	memSize:= NewCapacity * SizeOf(THashItem);
		FCapacity:= NewCapacity;
	end;
end;

{-----------------------------------------------------------------------------}
procedure THashList.SetCount(NewCount: Integer);
begin
	if((NewCount < 0) or (NewCount > MaxListSize)) then Error;
	if(NewCount > FCapacity) then SetCapacity(NewCount);
	if(NewCount > FCount) then
		FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(THashItem), 0);
	FCount:= NewCount;
end;



{ --- Class THashTable ---
	it's just a list of THashItems.
     you provide a key (string) and an object;
     a unique numeric key (longint) is compute (see hash);
     when you get an object, you provide string key, and as fast as possible
     the object is here.
     Really fast;
     Really smart, because of string keys.
}


{-----------------------------------------------------------------------------}
constructor THashTable.Create;
begin
	inherited Create;
     Ftable:= THashList.Create;
end;

{-----------------------------------------------------------------------------}
destructor THashTable.Destroy;
begin
	Ftable.Free;
	inherited Destroy;
end;

{-----------------------------------------------------------------------------}
procedure THashTable.Error;
begin
	raise EListError.CreateRes(SListIndexError);
end;

{-----------------------------------------------------------------------------}
{
	Add 'value' object with key 'key'
}
procedure THashTable.Add(const key: string; value: TObject);
var
	item:	THashItem;
begin
	item.key:= hash(pointer(longint(@key)+1),length(key),0);
     item.obj:= value;
	Ftable.Add(item);
end;

{-----------------------------------------------------------------------------}
{
	Get object with key 'key'
}
function THashTable.Get(const key: string): TObject;
var
	index:	integer;
begin
	index:= Ftable.IndexOf(hash(pointer(longint(@key)+1),length(key),0));
	if(index<0) then Error;
     result:= Ftable[index].obj;
end;

{-----------------------------------------------------------------------------}
{
	Detach (remove item, do not dispose object) object with key 'key'
}
procedure THashTable.Detach(const key: string);
var
	index:	integer;
begin
	index:= Ftable.IndexOf(hash(pointer(longint(@key)+1),length(key),0));
     if(index>=0) then
     	Ftable.Detach(index);
end;

{-----------------------------------------------------------------------------}
{
	Delete (remove item, dispose object) object with key 'key'
}
procedure THashTable.Delete(const key: string);
var
	index:	integer;
begin
	index:= Ftable.IndexOf(hash(pointer(longint(@key)+1),length(key),0));
     if(index>=0) then
     	Ftable.Delete(index);
end;

{-----------------------------------------------------------------------------}
{
	Clear the list; i.e: remove all the items (detach or delete depending of 'dt')
}
procedure THashTable.Clear(dt: TDeleteType);
begin
	Ftable.Clear(dt);
end;

{-----------------------------------------------------------------------------}
procedure THashTable.Pack;
begin
	Ftable.Pack;
end;

{-----------------------------------------------------------------------------}
function  THashTable.getCount: integer;				begin result:= Ftable.Count; end;
procedure THashTable.setCount(count: integer);		begin Ftable.Count:= count; end;
function  THashTable.getCapacity: integer;			begin result:= Ftable.Capacity; end;
procedure THashTable.setCapacity(capacity: integer);	begin Ftable.Capacity:= capacity; end;
function  THashTable.getDeleteType: TDeleteType;		begin result:= Ftable.DeleteType; end;
procedure THashTable.setDeleteType(dt: TDeleteType);	begin Ftable.DeleteType:= dt; end;
function  THashTable.getItem(index: integer): TObject;	begin result:= Ftable[index].obj; end;

{-----------------------------------------------------------------------------}
procedure THashTable.setItem(index: integer; obj: TObject);
var
	item:	THashItem;
begin
	item.key:= Ftable[index].key;
     item.obj:= obj;
	Ftable[index]:= item;
end;

{-----------------------------------------------------------------------------}
{ original code from lookup2.c, by Bob Jenkins, December 1996
	http://ourworld.compuserve.com/homepages/bob_jenkins/
     PLEASE, let me know if there is problem with it, or if you have a better one. THANKS.
}
function hash(key: Pointer; length: longint; level: longint): longint;
var
	a,b,c:		longint;
     len:			longint;
     k: 			array12Ptr;
     lp:			longPtr;

begin
	k:= array12Ptr(key);
	len:= length;
     a:= $9E3779B9;
     b:= a;
     c:= level;

     if((longint(key) and 3) <> 0) then begin
	     while(len>=12) do begin	{unaligned}
			inc(a, (longint(k^[00]) +(longint(k^[01]) shl 8) + (longint(k^[02]) shl 16) + (longint(k^[03]) shl 24)));
               inc(b, (longint(k^[04]) +(longint(k^[05]) shl 8) + (longint(k^[06]) shl 16) + (longint(k^[07]) shl 24)));
               inc(c, (longint(k^[08]) +(longint(k^[09]) shl 8) + (longint(k^[10]) shl 16) + (longint(k^[11]) shl 24)));

               {mix(a,b,c);}
			inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor (c shr 13);
			inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor (a shl 8);
			inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor (b shr 13);
			inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor (c shr 12);
			inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor (a shl 16);
			inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor (b shr 5);
			inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor (c shr 3);
		     inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor (a shl 10);
			inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor (b shr 15);

               inc(longint(k),12);
               dec(len,12);
          end;
     end

     else begin
	     while(len>=12) do begin	{aligned}
          	lp:= longPtr(k);
			inc(a, lp^); inc(lp,4);
			inc(b, lp^); inc(lp,4);
               inc(c, lp^);

               {mix(a,b,c);}
			inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor (c shr 13);
			inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor (a shl 8);
			inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor (b shr 13);
			inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor (c shr 12);
			inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor (a shl 16);
			inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor (b shr 5);
			inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor (c shr 3);
		     inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor (a shl 10);
			inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor (b shr 15);

               inc(longint(k),12);
               dec(len,12);
          end;
     end;

     inc(c,length);

	if(len>=11) then inc(c, (longint(k^[10]) shl 24));
	if(len>=10) then inc(c, (longint(k^[9]) shl 16));
	if(len>=9) then inc(c, (longint(k^[8]) shl 8));
	if(len>=8) then inc(b, (longint(k^[7]) shl 24));
	if(len>=7) then inc(b, (longint(k^[6]) shl 16));
	if(len>=6) then inc(b, (longint(k^[5]) shl 8));
	if(len>=5) then inc(b, longint(k^[4]));
	if(len>=4) then inc(a, (longint(k^[3]) shl 24));
	if(len>=3) then inc(a, (longint(k^[2]) shl 16));
	if(len>=2) then inc(a, (longint(k^[1]) shl 8));
	if(len>=1) then inc(a, longint(k^[0]));

     {mix(a,b,c);}
	inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor (c shr 13);
	inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor (a shl 8);
	inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor (b shr 13);
	inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor (c shr 12);
	inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor (a shl 16);
	inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor (b shr 5);
	inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor (c shr 3);
     inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor (a shl 10);
	inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor (b shr 15);

     result:= longint(c);
end;

end.