[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]
{
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.
[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]