index 955e599bf9f1ba6bb1516f2a5545362b82a6a37b..cb6d35c0f8c684b58320c369907b9a3141e1d664 100644 (file)
--- a/src/shared/hashtable.pas
+++ b/src/shared/hashtable.pas
-(* Copyright (C) DooM 2D:Forever Developers
+(* Copyright (C) Doom 2D: Forever Developers
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
- * the Free Software Foundation, either version 3 of the License, or
- * (at your option) any later version.
+ * the Free Software Foundation, version 3 of the License ONLY.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
{.$DEFINE RBHASH_DEBUG_DELETE}
{.$DEFINE RBHASH_DEBUG_COMPACT}
{$IF DEFINED(D2F_DEBUG)}
- {$DEFINE RBHASH_SANITY_CHECKS}
+ {.$DEFINE RBHASH_SANITY_CHECKS}
{$ENDIF}
// hash table (robin hood)
unit hashtable;
interface
-
+(*
+ * HashObjT: class that contains class methods:
+ * class function hash (const[ref] k: KeyT): LongWord;
+ * class function equ (const[ref] a, b: KeyT): Boolean;
+ * class procedure freekey (var k: KeyT); // this may free key
+ *)
type
// WARNING! don't put structures into hash, use ponters or ids!
- generic THashBase<KeyT, ValueT> = class(TObject)
+ generic THashBase<KeyT, ValueT, HashObjT> = class(TObject)
private
- const InitSize = {$IF DEFINED(D2F_DEBUG)}16{$ELSE}512{$ENDIF}; // *MUST* be power of two
+ const InitSize = {$IF DEFINED(RBHASH_SANITY_CHECKS)}16{$ELSE}256{$ENDIF}; // *MUST* be power of two
const LoadFactorPrc = 90; // it is ok for robin hood hashes
public
- type THashFn = function (constref o: KeyT): LongWord;
- type TEquFn = function (constref a, b: KeyT): Boolean;
-
- private
type
PEntry = ^TEntry;
TEntry = record
+ public
key: KeyT;
value: ValueT;
+ private
hash: LongWord; // key hash or 0
- nextFree: Integer;
+ nextFree: PEntry; // next free entry
+ private
+ function getEmpty (): Boolean; inline;
+ public
+ property empty: Boolean read getEmpty;
+ property keyhash: LongWord read hash; // cannot be 0
end;
+ type TFreeValueFn = procedure (var v: ValueT); // this may free value
+ type TIteratorFn = function (constref k: KeyT; constref v: ValueT): Boolean is nested; // return `true` to stop
+ type TIteratorExFn = function (constref k: KeyT; constref v: ValueT; keyhash: LongWord): Boolean is nested; // return `true` to stop
+
private
- hashfn: THashFn;
- equfn: TEquFn;
+ type
+ TEntryArray = array of TEntry;
+
+ public
+ type
+ TValEnumerator = record
+ private
+ mEntries: TEntryArray;
+ mFirstEntry, mLastEntry, cur: Integer;
+ public
+ constructor Create (const aents: TEntryArray; afirst, alast: Integer);
+ function MoveNext (): Boolean; inline;
+ function getCurrent (): ValueT; inline;
+ function GetEnumerator (): TValEnumerator; inline;
+ property Current: ValueT read getCurrent;
+ end;
+
+ TKeyEnumerator = record
+ private
+ mEntries: TEntryArray;
+ mFirstEntry, mLastEntry, cur: Integer;
+ public
+ constructor Create (const aents: TEntryArray; afirst, alast: Integer);
+ function MoveNext (): Boolean; inline;
+ function getCurrent (): KeyT; inline;
+ function GetEnumerator (): TKeyEnumerator; inline;
+ property Current: KeyT read getCurrent;
+ end;
+
+ TKeyValEnumerator = record
+ private
+ mEntries: TEntryArray;
+ mFirstEntry, mLastEntry, cur: Integer;
+ public
+ constructor Create (const aents: TEntryArray; afirst, alast: Integer);
+ function MoveNext (): Boolean; inline;
+ function getCurrent (): PEntry; inline;
+ function GetEnumerator (): TKeyValEnumerator; inline;
+ property Current: PEntry read getCurrent;
+ end;
+
+ private
+ freevalfn: TFreeValueFn;
mBuckets: array of PEntry; // entries, points to mEntries elements
mBucketsUsed: Integer;
- mEntries: array of TEntry;
+ mEntries: TEntryArray;
+ {$IFDEF RBHASH_SANITY_CHECKS}
mEntriesUsed: Integer;
- mFreeEntryHead: Integer;
+ {$ENDIF}
+ mFreeEntryHead: PEntry;
+ mFirstEntry, mLastEntry: Integer;
mSeed: LongWord;
private
function allocEntry (): PEntry;
procedure releaseEntry (e: PEntry);
- //function distToStIdx (idx: LongWord): LongWord; inline;
+ function distToStIdx (idx: LongWord): LongWord; inline;
procedure putEntryInternal (swpe: PEntry);
function getCapacity (): Integer; inline;
+ procedure freeEntries ();
+
public
- constructor Create (ahashfn: THashFn; aequfn: TEquFn);
+ constructor Create (afreevalfn: TFreeValueFn=nil);
destructor Destroy (); override;
procedure clear ();
+ procedure reset (); // don't shrink buckets
procedure rehash ();
procedure compact (); // call this instead of `rehash()` after alot of deletions
- function get (constref akey: KeyT; out rval: ValueT): Boolean; // `true`: found
- function put (constref akey: KeyT; constref aval: ValueT): Boolean; // `true`: replaced
- function has (constref akey: KeyT): Boolean; // `true`: found
- function del (constref akey: KeyT): Boolean; // `true`: deleted
+ // you may pass `keyhash` to bypass hash calculation
+ function get (constref akey: KeyT; out rval: ValueT; keyhashin: PLongWord=nil): Boolean; // `true`: found
+ // the function may return calculated value hash in `keyhash`
+ function put (constref akey: KeyT; constref aval: ValueT; keyhashout: PLongWord=nil): Boolean; // `true`: replaced
+ // you may pass `keyhash` to bypass hash calculation
+ function has (constref akey: KeyT; keyhashin: PLongWord=nil): Boolean; // `true`: found
+ // you may pass `keyhash` to bypass hash calculation
+ function del (constref akey: KeyT; keyhashin: PLongWord=nil): Boolean; // `true`: deleted
+
+ //WARNING! don't modify table in iterator (queries are ok, though)
+ function forEach (it: TIteratorFn): Boolean; overload;
+ function forEach (it: TIteratorExFn): Boolean; overload;
+
+ // default `for ... in` enums values
+ function GetEnumerator (): TValEnumerator;
+ function byKey (): TKeyEnumerator;
+ function byValue (): TValEnumerator;
+ function byKeyValue (): TKeyValEnumerator; // PEntry
property count: Integer read mBucketsUsed;
property capacity: Integer read getCapacity;
end;
-
type
TJoaatHasher = record
private
procedure reset (); inline; overload;
procedure reset (aseed: LongWord); inline; overload;
- procedure put (const buf; len: LongWord);
+ procedure put (constref buf; len: LongWord);
// current hash value
// you can continue putting data, as this is not destructive
type
- THashIntInt = specialize THashBase<Integer, Integer>;
+ THashKeyInt = class
+ public
+ class function hash (const k: Integer): LongWord; inline;
+ class function equ (const a, b: Integer): Boolean; inline;
+ class procedure freekey (k: Integer); inline;
+ end;
+
+ THashKeyStr = class
+ public
+ class function hash (const k: AnsiString): LongWord; inline;
+ class function equ (const a, b: AnsiString): Boolean; inline;
+ class procedure freekey (var k: AnsiString); inline;
+ end;
+
+ // case-insensitive (ansi)
+ THashKeyStrAnsiCI = class
+ public
+ class function hash (const k: AnsiString): LongWord; inline;
+ class function equ (const a, b: AnsiString): Boolean; inline;
+ class procedure freekey (var k: AnsiString); inline;
+ end;
-function hashNewIntInt (): THashIntInt;
+type
+ THashIntInt = specialize THashBase<Integer, Integer, THashKeyInt>;
+ THashStrInt = specialize THashBase<AnsiString, Integer, THashKeyStr>;
+ THashStrCIInt = specialize THashBase<AnsiString, Integer, THashKeyStrAnsiCI>;
+ THashIntStr = specialize THashBase<Integer, AnsiString, THashKeyInt>;
+ THashStrStr = specialize THashBase<AnsiString, AnsiString, THashKeyStr>;
+ THashStrCIStr = specialize THashBase<AnsiString, AnsiString, THashKeyStrAnsiCI>;
+ THashStrVariant = specialize THashBase<AnsiString, Variant, THashKeyStr>;
+ THashStrCIVariant = specialize THashBase<AnsiString, Variant, THashKeyStrAnsiCI>;
function u32Hash (a: LongWord): LongWord; inline;
-function fnvHash (const buf; len: LongWord): LongWord;
-function joaatHash (const buf; len: LongWord): LongWord;
+function fnvHash (constref buf; len: LongWord): LongWord;
+function joaatHash (constref buf; len: LongWord; seed: LongWord=0): LongWord;
+function joaatHashPtr (buf: Pointer; len: LongWord; seed: LongWord=0): LongWord;
-function nextPOT (x: LongWord): LongWord; inline;
+// has to be public due to FPC generics limitation
+function nextPOTU32 (x: LongWord): LongWord; inline;
implementation
uses
- SysUtils;
+ SysUtils, Variants;
// ////////////////////////////////////////////////////////////////////////// //
{$PUSH}
{$RANGECHECKS OFF}
-function nextPOT (x: LongWord): LongWord; inline;
+function nextPOTU32 (x: LongWord): LongWord; inline;
begin
result := x;
result := result or (result shr 1);
{$POP}
-// ////////////////////////////////////////////////////////////////////////// //
-function hiiequ (constref a, b: Integer): Boolean; begin result := (a = b); end;
-
-{$PUSH}
-{$RANGECHECKS OFF}
-function hiihash (constref k: Integer): LongWord;
-begin
- result := k;
- result -= (result shl 6);
- result := result xor (result shr 17);
- result -= (result shl 9);
- result := result xor (result shl 4);
- result -= (result shl 3);
- result := result xor (result shl 10);
- result := result xor (result shr 15);
-end;
-{$POP}
-
-
-function hashNewIntInt (): THashIntInt;
-begin
- result := THashIntInt.Create(hiihash, hiiequ);
-end;
-
-
// ////////////////////////////////////////////////////////////////////////// //
{$PUSH}
{$RANGECHECKS OFF}
reset(aseed);
end;
-
procedure TJoaatHasher.reset (); inline; overload;
begin
hash := seed;
end;
-
procedure TJoaatHasher.reset (aseed: LongWord); inline; overload;
begin
seed := aseed;
hash := aseed;
end;
-
-procedure TJoaatHasher.put (const buf; len: LongWord);
+procedure TJoaatHasher.put (constref buf; len: LongWord);
var
bytes: PByte;
h: LongWord;
hash := h;
end;
-
function TJoaatHasher.value: LongWord; inline;
begin
result := hash;
{$POP}
-function joaatHash (const buf; len: LongWord): LongWord;
+// ////////////////////////////////////////////////////////////////////////// //
+{$PUSH}
+{$RANGECHECKS OFF}
+function joaatHash (constref buf; len: LongWord; seed: LongWord=0): LongWord;
var
- h: TJoaatHasher;
+ b: PByte;
+ f: LongWord;
begin
- h := TJoaatHasher.Create(0);
- h.put(buf, len);
- result := h.value;
+ result := seed;
+ b := PByte(@buf);
+ for f := 1 to len do
+ begin
+ result += b^;
+ result += (result shl 10);
+ result := result xor (result shr 6);
+ Inc(b);
+ end;
+ // finalize
+ result += (result shl 3);
+ result := result xor (result shr 11);
+ result += (result shl 15);
end;
+function joaatHashPtr (buf: Pointer; len: LongWord; seed: LongWord=0): LongWord;
+var
+ b: PByte;
+ f: LongWord;
+begin
+ result := seed;
+ b := PByte(buf);
+ for f := 1 to len do
+ begin
+ result += b^;
+ result += (result shl 10);
+ result := result xor (result shr 6);
+ Inc(b);
+ end;
+ // finalize
+ result += (result shl 3);
+ result := result xor (result shr 11);
+ result += (result shl 15);
+end;
+{$POP}
-// ////////////////////////////////////////////////////////////////////////// //
{$PUSH}
{$RANGECHECKS OFF}
// fnv-1a: http://www.isthe.com/chongo/tech/comp/fnv/
-function fnvHash (const buf; len: LongWord): LongWord;
+function fnvHash (constref buf; len: LongWord): LongWord;
var
b: PByte;
begin
end;
{$POP}
-
{$PUSH}
{$RANGECHECKS OFF}
function u32Hash (a: LongWord): LongWord; inline;
end;
{$POP}
+function locase1251 (ch: AnsiChar): AnsiChar; inline;
+begin
+ if ch < #128 then
+ begin
+ if (ch >= 'A') and (ch <= 'Z') then Inc(ch, 32);
+ end
+ else
+ begin
+ if (ch >= #192) and (ch <= #223) then
+ begin
+ Inc(ch, 32);
+ end
+ else
+ begin
+ case ch of
+ #168, #170, #175: Inc(ch, 16);
+ #161, #178: Inc(ch);
+ end;
+ end;
+ end;
+ result := ch;
+end;
+
// ////////////////////////////////////////////////////////////////////////// //
-constructor THashBase.Create (ahashfn: THashFn; aequfn: TEquFn);
+// THashKeyInt
+class function THashKeyInt.hash (const k: Integer): LongWord; inline;
begin
- if not assigned(ahashfn) then raise Exception.Create('cannot create hash without hash function');
- if not assigned(aequfn) then raise Exception.Create('cannot create hash without equality function');
+ result := LongWord(k);
+ result -= (result shl 6);
+ result := result xor (result shr 17);
+ result -= (result shl 9);
+ result := result xor (result shl 4);
+ result -= (result shl 3);
+ result := result xor (result shl 10);
+ result := result xor (result shr 15);
+end;
+
+class function THashKeyInt.equ (const a, b: Integer): Boolean; inline; begin result := (a = b); end;
+class procedure THashKeyInt.freekey (k: Integer); inline; begin end;
+
- hashfn := ahashfn;
- equfn := aequfn;
+// ////////////////////////////////////////////////////////////////////////// //
+// THashKeyStr
+class function THashKeyStr.hash (const k: AnsiString): LongWord; inline; begin if (Length(k) > 0) then result := fnvHash((@k[1])^, Length(k)) else result := 0; end;
+class function THashKeyStr.equ (const a, b: AnsiString): Boolean; inline; begin result := (a = b); end;
+class procedure THashKeyStr.freekey (var k: AnsiString); inline; begin k := ''; end;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+// case-insensitive (ansi)
+{$PUSH}
+{$RANGECHECKS OFF}
+// fnv-1a: http://www.isthe.com/chongo/tech/comp/fnv/
+function fnvHashLo (constref buf; len: LongWord): LongWord;
+var
+ b: PAnsiChar;
+begin
+ b := @buf;
+ result := 2166136261; // fnv offset basis
+ while (len > 0) do
+ begin
+ result := result xor Byte(locase1251(b^));
+ result := result*16777619; // 32-bit fnv prime
+ Inc(b);
+ Dec(len);
+ end;
+end;
+{$POP}
+
+class function THashKeyStrAnsiCI.hash (const k: AnsiString): LongWord; inline; begin if (Length(k) > 0) then result := fnvHashLo((@k[1])^, Length(k)) else result := 0; end;
+class function THashKeyStrAnsiCI.equ (const a, b: AnsiString): Boolean; inline;
+var
+ f: Integer;
+begin
+ result := false;
+ if (Length(a) = Length(b)) then
+ begin
+ for f := 1 to Length(a) do if (locase1251(a[f]) <> locase1251(b[f])) then exit;
+ end;
+ result := true;
+end;
+class procedure THashKeyStrAnsiCI.freekey (var k: AnsiString); inline; begin k := ''; end;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+function THashBase.TEntry.getEmpty (): Boolean; inline; begin result := (hash = 0); end;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+function THashBase.getCapacity (): Integer; inline; begin result := Length(mBuckets); end;
+
+
+constructor THashBase.Create (afreevalfn: TFreeValueFn=nil);
+begin
+ freevalfn := afreevalfn;
mSeed := u32Hash($29a);
+ mFreeEntryHead := nil;
+ mFirstEntry := -1;
+ mLastEntry := -1;
clear();
end;
destructor THashBase.Destroy ();
begin
+ freeEntries();
mBuckets := nil;
mEntries := nil;
inherited;
end;
-function THashBase.getCapacity (): Integer; inline; begin result := Length(mBuckets); end;
+procedure THashBase.freeEntries ();
+var
+ f: Integer;
+ e: PEntry;
+begin
+ if (mFirstEntry >= 0) then
+ begin
+ for f := mFirstEntry to mLastEntry do
+ begin
+ e := @mEntries[f];
+ if not e.empty then
+ begin
+ HashObjT.freekey(e.key);
+ if assigned(freevalfn) then freevalfn(e.value) else e.value := Default(ValueT);
+ e.key := Default(KeyT);
+ e.value := Default(ValueT);
+ e.hash := 0;
+ end;
+ end;
+ end
+ else if (Length(mEntries) > 0) then
+ begin
+ FillChar(mEntries[0], Length(mEntries)*sizeof(mEntries[0]), 0);
+ end;
+ mFreeEntryHead := nil;
+ mFirstEntry := -1;
+ mLastEntry := -1;
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ mEntriesUsed := 0;
+ {$ENDIF}
+end;
+
+
+procedure THashBase.clear ();
+begin
+ freeEntries();
+ {
+ SetLength(mBuckets, InitSize);
+ FillChar(mBuckets[0], InitSize*sizeof(mBuckets[0]), 0);
+ SetLength(mEntries, InitSize);
+ FillChar(mEntries[0], InitSize*sizeof(mEntries[0]), 0);
+ }
+ mFreeEntryHead := nil;
+ mBuckets := nil;
+ mEntries := nil;
+ mFirstEntry := -1;
+ mLastEntry := -1;
+ mBucketsUsed := 0;
+end;
+
+
+procedure THashBase.reset ();
+//var idx: Integer;
+begin
+ freeEntries();
+ if (mBucketsUsed > 0) then
+ begin
+ //for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
+ FillChar(mBuckets[0], Length(mBuckets)*sizeof(mBuckets[0]), 0);
+ mBucketsUsed := 0;
+ end;
+end;
function THashBase.allocEntry (): PEntry;
+var
+ idx: Integer;
begin
+ if (mFreeEntryHead = nil) then
+ begin
+ // nothing was allocated, so allocate something now
+ if (Length(mBuckets) = 0) then
+ begin
+ assert(Length(mEntries) = 0);
+ assert(mFirstEntry = -1);
+ assert(mLastEntry = -1);
+ assert(mBucketsUsed = 0);
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ mEntriesUsed := 0;
+ {$ENDIF}
+ SetLength(mBuckets, InitSize);
+ FillChar(mBuckets[0], InitSize*sizeof(mBuckets[0]), 0);
+ SetLength(mEntries, InitSize);
+ FillChar(mEntries[0], InitSize*sizeof(mEntries[0]), 0);
+ end;
+ if (mLastEntry = High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (0.0)');
+ Inc(mLastEntry);
+ if (mFirstEntry = -1) then
+ begin
+ if (mLastEntry <> 0) then raise Exception.Create('internal error in hash entry allocator (0.1)');
+ mFirstEntry := 0;
+ end;
+ result := @mEntries[mLastEntry];
+ result.nextFree := nil; // just in case
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ Inc(mEntriesUsed);
+ {$ENDIF}
+ exit;
+ end;
{$IFDEF RBHASH_SANITY_CHECKS}
- if (mFreeEntryHead = -1) then raise Exception.Create('internal error in hash entry allocator (0)');
- if (mEntries[mFreeEntryHead].hash <> 0) then raise Exception.Create('internal error in hash entry allocator (1)');
+ if (mFreeEntryHead = nil) then raise Exception.Create('internal error in hash entry allocator (0)');
+ if (not mFreeEntryHead.empty) then raise Exception.Create('internal error in hash entry allocator (1)');
{$ENDIF}
- result := @mEntries[mFreeEntryHead];
+ result := mFreeEntryHead;
mFreeEntryHead := result.nextFree;
+ {$IFDEF RBHASH_SANITY_CHECKS}
Inc(mEntriesUsed);
- result.nextFree := -1;
+ {$ENDIF}
+ result.nextFree := nil; // just in case
+ // fix mFirstEntry and mLastEntry
+ idx := Integer((PtrUInt(result)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0]));
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (idx < 0) or (idx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid entry address)');
+ if (result <> @mEntries[idx]) then raise Exception.Create('internal error in hash entry allocator (wtf?!)');
+ {$ENDIF}
+ if (mFirstEntry < 0) or (idx < mFirstEntry) then mFirstEntry := idx;
+ if (idx > mLastEntry) then mLastEntry := idx;
end;
procedure THashBase.releaseEntry (e: PEntry);
var
- idx: LongWord;
+ cidx, idx: Integer;
begin
{$IFDEF RBHASH_SANITY_CHECKS}
if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator');
+ if (mEntriesUsed <> mBucketsUsed) then raise Exception.Create('internal error in hash entry allocator (entry/bucket count mismatch)');
if (e = nil) then raise Exception.Create('internal error in hash entry allocator (trying to release nil entry)');
- if (e.nextFree <> -1) or (e.hash = 0) then raise Exception.Create('internal error in hash entry allocator (trying to release unallocated entry)');
+ if (e.empty) then raise Exception.Create('internal error in hash entry allocator (trying to release unallocated entry)');
+ {$ENDIF}
+ idx := Integer((PtrUInt(e)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0]));
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (idx < 0) or (idx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid entry address)');
+ if (e <> @mEntries[idx]) then raise Exception.Create('internal error in hash entry allocator (wtf?!)');
{$ENDIF}
- idx := LongWord((PtrUInt(e)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0]));
+ HashObjT.freekey(e.key);
+ if assigned(freevalfn) then freevalfn(e.value) else e.value := Default(ValueT);
{$IFDEF RBHASH_SANITY_CHECKS}
- if (idx >= Length(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid calculated index)');
+ Dec(mEntriesUsed);
{$ENDIF}
+ e.key := Default(KeyT);
+ e.value := Default(ValueT);
e.hash := 0;
e.nextFree := mFreeEntryHead;
- mFreeEntryHead := idx;
- Dec(mEntriesUsed);
+ mFreeEntryHead := e;
+ // fix mFirstEntry and mLastEntry
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (mFirstEntry < 0) or (mLastEntry < 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 0)');
+ {$ENDIF}
+ if (mFirstEntry = mLastEntry) then
+ begin
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (mEntriesUsed <> 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 1)');
+ {$ENDIF}
+ mFreeEntryHead := nil;
+ mFirstEntry := -1;
+ mLastEntry := -1;
+ end
+ else
+ begin
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 2)');
+ {$ENDIF}
+ // fix first entry index
+ if (idx = mFirstEntry) then
+ begin
+ cidx := idx+1;
+ while (mEntries[cidx].empty) do Inc(cidx);
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (cidx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 3)');
+ {$ENDIF}
+ mFirstEntry := cidx;
+ end;
+ // fix last entry index
+ if (idx = mLastEntry) then
+ begin
+ cidx := idx-1;
+ while (mEntries[cidx].empty) do Dec(cidx);
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (cidx < 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 3)');
+ {$ENDIF}
+ mLastEntry := cidx;
+ end;
+ end;
end;
-(*
function THashBase.distToStIdx (idx: LongWord): LongWord; inline;
begin
{$IFDEF RBHASH_SANITY_CHECKS}
assert(idx < Length(mBuckets));
assert(mBuckets[idx] <> nil);
{$ENDIF}
- result := mBuckets[idx].hash and High(mBuckets);
+ result := (mBuckets[idx].hash xor mSeed) and High(mBuckets);
if (result <= idx) then result := idx-result else result := idx+(Length(mBuckets)-result);
end;
-*)
-function THashBase.has (constref akey: KeyT): Boolean;
+function THashBase.has (constref akey: KeyT; keyhashin: PLongWord=nil): Boolean;
var
khash, idx: LongWord;
dist, pdist: LongWord;
- bhigh: LongWord;
+ bhigh, xseed: LongWord;
begin
result := false;
if (mBucketsUsed = 0) then exit;
bhigh := High(mBuckets);
- khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
- idx := khash and bhigh;
+ xseed := mSeed;
+
+ if (keyhashin <> nil) then
+ begin
+ khash := keyhashin^;
+ if (khash = 0) then khash := HashObjT.hash(akey);
+ end
+ else
+ begin
+ khash := HashObjT.hash(akey);
+ end;
+ if (khash = 0) then khash := $29a;
+
+ idx := (khash xor xseed) and bhigh;
if (mBuckets[idx] = nil) then exit;
for dist := 0 to bhigh do
begin
if (mBuckets[idx] = nil) then break;
- //pdist := distToStIdx(idx);
- pdist := mBuckets[idx].hash and bhigh;
- if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
- //
+ pdist := distToStIdx(idx);
if (dist > pdist) then break;
- result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
+ result := (mBuckets[idx].hash = khash) and HashObjT.equ(mBuckets[idx].key, akey);
if result then break;
idx := (idx+1) and bhigh;
end;
end;
-function THashBase.get (constref akey: KeyT; out rval: ValueT): Boolean;
+function THashBase.get (constref akey: KeyT; out rval: ValueT; keyhashin: PLongWord=nil): Boolean;
var
khash, idx: LongWord;
dist, pdist: LongWord;
- bhigh: LongWord;
+ bhigh, xseed: LongWord;
begin
result := false;
if (mBucketsUsed = 0) then begin rval := Default(ValueT); exit; end;
bhigh := High(mBuckets);
- khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
- idx := khash and bhigh;
- if (mBuckets[idx] = nil) then begin rval := Default(ValueT); exit; end;
+ xseed := mSeed;
+
+ if (keyhashin <> nil) then
+ begin
+ khash := keyhashin^;
+ if (khash = 0) then khash := HashObjT.hash(akey);
+ end
+ else
+ begin
+ khash := HashObjT.hash(akey);
+ end;
+ if (khash = 0) then khash := $29a;
+
+ idx := (khash xor xseed) and bhigh;
for dist := 0 to bhigh do
begin
if (mBuckets[idx] = nil) then break;
- //pdist := distToStIdx(idx);
- pdist := mBuckets[idx].hash and bhigh;
- if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
- //
+ pdist := distToStIdx(idx);
if (dist > pdist) then break;
- result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
- if result then
- begin
- rval := mBuckets[idx].value;
- break;
- end;
+ result := (mBuckets[idx].hash = khash) and HashObjT.equ(mBuckets[idx].key, akey);
+ if result then begin rval := mBuckets[idx].value; break; end;
idx := (idx+1) and bhigh;
end;
procedure THashBase.putEntryInternal (swpe: PEntry);
var
idx, dist, pcur, pdist: LongWord;
- tmpe: PEntry; // current entry to swap (or nothing)
- bhigh: LongWord;
+ tmpe: PEntry;
+ bhigh, xseed: LongWord;
begin
bhigh := High(mBuckets);
- idx := swpe.hash and bhigh;
+ xseed := mSeed;
+ idx := (swpe.hash xor xseed) and bhigh;
{$IFDEF RBHASH_DEBUG_INSERT}writeln('inserting key ', swpe.key, '; value=', swpe.value, '; wantidx=', idx, '; bhigh=', bhigh);{$ENDIF}
pcur := 0;
for dist := 0 to bhigh do
Inc(mBucketsUsed);
break;
end;
- //pdist := distToStIdx(idx);
- pdist := mBuckets[idx].hash and bhigh;
- if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
- //
+ pdist := distToStIdx(idx);
if (pcur > pdist) then
begin
// swapping the current bucket with the one to insert
end;
-function THashBase.put (constref akey: KeyT; constref aval: ValueT): Boolean;
+function THashBase.put (constref akey: KeyT; constref aval: ValueT; keyhashout: PLongWord=nil): Boolean;
var
khash, idx, dist, pdist: LongWord;
swpe: PEntry = nil; // current entry to swap (or nothing)
- bhigh: LongWord;
+ bhigh, xseed: LongWord;
newsz, eidx: Integer;
begin
result := false;
bhigh := High(mBuckets);
- khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
- idx := khash and bhigh;
+ xseed := mSeed;
+ khash := HashObjT.hash(akey);
+ if (khash = 0) then khash := $29a;
+ if (keyhashout <> nil) then keyhashout^ := khash;
+ idx := (khash xor xseed) and bhigh;
// check if we already have this key
if (mBucketsUsed <> 0) and (mBuckets[idx] <> nil) then
for dist := 0 to bhigh do
begin
if (mBuckets[idx] = nil) then break;
- //pdist := distToStIdx(idx);
- pdist := mBuckets[idx].hash and bhigh;
- if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
- //
+ pdist := distToStIdx(idx);
if (dist > pdist) then break;
- result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
+ result := (mBuckets[idx].hash = khash) and HashObjT.equ(mBuckets[idx].key, akey);
if result then
begin
// replace element
- //mBuckets[idx].key := akey;
+ HashObjT.freekey(mBuckets[idx].key);
+ if assigned(freevalfn) then freevalfn(mBuckets[idx].value) else mBuckets[idx].value := Default(ValueT);
+ mBuckets[idx].key := akey;
mBuckets[idx].value := aval;
exit;
end;
{$ENDIF}
SetLength(mBuckets, newsz);
// resize entries array
- eidx := newsz;
+ eidx := Length(mEntries);
SetLength(mEntries, newsz);
while (eidx < Length(mEntries)) do begin mEntries[eidx].hash := 0; Inc(eidx); end;
// mFreeEntryHead will be fixed in `rehash()`
// reinsert entries
rehash();
- // as seed was changed, recalc hash
- khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
end;
// create new entry
// see http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
-function THashBase.del (constref akey: KeyT): Boolean;
+function THashBase.del (constref akey: KeyT; keyhashin: PLongWord=nil): Boolean;
var
khash, idx, idxnext, pdist, dist: LongWord;
- bhigh: LongWord;
+ bhigh, xseed: LongWord;
begin
result := false;
if (mBucketsUsed = 0) then exit;
bhigh := High(mBuckets);
- khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
- idx := khash and bhigh;
+ xseed := mSeed;
+
+ if (keyhashin <> nil) then
+ begin
+ khash := keyhashin^;
+ if (khash = 0) then khash := HashObjT.hash(akey);
+ end
+ else
+ begin
+ khash := HashObjT.hash(akey);
+ end;
+ if (khash = 0) then khash := $29a;
+
+ idx := (khash xor xseed) and bhigh;
// find key
if (mBuckets[idx] = nil) then exit; // no key
for dist := 0 to bhigh do
begin
if (mBuckets[idx] = nil) then break;
- //pdist := distToStIdx(idxcur);
- pdist := mBuckets[idx].hash and bhigh;
- if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
- //
+ pdist := distToStIdx(idx);
if (dist > pdist) then break;
- result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
+ result := (mBuckets[idx].hash = khash) and HashObjT.equ(mBuckets[idx].key, akey);
if result then break;
idx := (idx+1) and bhigh;
end;
writeln(' dist=', dist, '; idx=', idx, '; idxnext=', idxnext, '; ce=', (mBuckets[idx] <> nil), '; ne=', (mBuckets[idxnext] <> nil));
{$ENDIF}
if (mBuckets[idxnext] = nil) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln(' idxnext nil');{$ENDIF} mBuckets[idx] := nil; break; end;
- //pdist := distToStIdx(idxnext);
- pdist := mBuckets[idxnext].hash and bhigh;
- if (pdist <= idxnext) then pdist := idxnext-pdist else pdist := idxnext+((bhigh+1)-pdist);
- //
+ pdist := distToStIdx(idxnext);
if (pdist = 0) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln(' pdist is zero');{$ENDIF} mBuckets[idx] := nil; break; end;
{$IFDEF RBHASH_DEBUG_DELETE}writeln(' pdist=', pdist);{$ENDIF}
mBuckets[idx] := mBuckets[idxnext];
end;
-procedure THashBase.clear ();
-var
- idx: Integer;
-begin
- SetLength(mBuckets, InitSize);
- for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
-
- SetLength(mEntries, Length(mBuckets));
- for idx := 0 to High(mEntries) do
- begin
- mEntries[idx].hash := 0;
- mEntries[idx].nextFree := idx+1;
- end;
- mEntries[High(mEntries)].nextFree := -1;
-
- mBucketsUsed := 0;
- mEntriesUsed := 0;
- mFreeEntryHead := 0;
-end;
-
-
procedure THashBase.rehash ();
var
- idx, lastfree: Integer;
- e: PEntry;
+ idx: Integer;
+ lastfree: PEntry;
+ e: PEntry = nil; // shut up, fpc!
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ cnt: Integer = 0;
+ {$ENDIF}
begin
// change seed, to minimize pathological cases
+ //TODO: use prng to generate new hash
if (mSeed = 0) then mSeed := $29a;
mSeed := u32Hash(mSeed);
// clear buckets
- for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
+ //for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
+ FillChar(mBuckets[0], Length(mBuckets)*sizeof(mBuckets[0]), 0);
mBucketsUsed := 0;
// reinsert entries
- mFreeEntryHead := -1;
- lastfree := -1;
+ mFreeEntryHead := nil;
+ lastfree := nil;
for idx := 0 to High(mEntries) do
begin
e := @mEntries[idx];
- if (e.hash <> 0) then
+ if (not e.empty) then
begin
- e.hash := hashfn(e.key) xor mSeed; if (e.hash = 0) then e.hash := $29a;
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (e.nextFree <> nil) then raise Exception.Create('internal error in rehash: inconsistent');
+ if (cnt = 0) and (idx <> mFirstEntry) then raise Exception.Create('internal error in rehash: inconsistent (1)');
+ Inc(cnt);
+ if (cnt = mBucketsUsed) and (idx <> mLastEntry) then raise Exception.Create('internal error in rehash: inconsistent (2)');
+ {$ENDIF}
+ // no need to recalculate hash
putEntryInternal(e);
end
else
begin
- if (lastfree <> -1) then mEntries[lastfree].nextFree := idx else mFreeEntryHead := idx;
- lastfree := idx;
+ if (lastfree <> nil) then lastfree.nextFree := e else mFreeEntryHead := e;
+ lastfree := e;
end;
end;
+ if (lastfree <> nil) then lastfree.nextFree := nil;
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (cnt <> mBucketsUsed) then raise Exception.Create('internal error in hash table resize (invalid first/last range; 0)');
+ if (cnt <> mEntriesUsed) then raise Exception.Create('internal error in hash table resize (invalid first/last range; 1)');
+ {$ENDIF}
end;
procedure THashBase.compact ();
var
newsz, didx, f: Integer;
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ cnt: Integer;
+ {$ENDIF}
begin
- newsz := nextPOT(LongWord(mBucketsUsed));
+ newsz := nextPOTU32(LongWord(mBucketsUsed));
if (newsz >= 1024*1024*1024) then exit;
if (newsz*2 >= Length(mBuckets)) then exit;
+ if (newsz*2 < 128) then exit;
{$IFDEF RBHASH_DEBUG_COMPACT}writeln('compacting; used=', mBucketsUsed, '; oldsizePOT=', newsz, '; newsize=', newsz*2);{$ENDIF}
newsz *= 2;
// move all entries to top
- didx := 0;
- while (didx < Length(mEntries)) do if (mEntries[didx].hash <> 0) then Inc(didx) else break;
- f := didx+1;
- while (f < Length(mEntries)) do if (mEntries[f].hash = 0) then Inc(f) else break;
- // copy entries
- while (f < Length(mEntries)) do
- begin
- if (mEntries[f].hash <> 0) then
+ if (mFirstEntry >= 0) then
+ begin
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (mBucketsUsed < 1) then raise Exception.Create('internal error in hash table (invalid bucket count; 0)');
+ {$ENDIF}
+ didx := 0;
+ while (didx < Length(mEntries)) do if (not mEntries[didx].empty) then Inc(didx) else break;
+ f := didx+1;
+ // copy entries
+ while true do
begin
- if (didx >= f) then raise Exception.Create('internal error in hash: inconsistent');
- mEntries[didx] := mEntries[f];
- mEntries[f].hash := 0;
- Inc(didx);
- while (didx < Length(mEntries)) do if (mEntries[didx].hash <> 0) then Inc(didx) else break;
+ if (not mEntries[f].empty) then
+ begin
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (didx >= f) then raise Exception.Create('internal error in hash: inconsistent');
+ {$ENDIF}
+ mEntries[didx] := mEntries[f];
+ mEntries[f].hash := 0;
+ Inc(didx);
+ if (f = mLastEntry) then break;
+ while (didx < Length(mEntries)) do if (not mEntries[didx].empty) then Inc(didx) else break;
+ end;
Inc(f);
- while (f < Length(mEntries)) do if (mEntries[f].hash = 0) then Inc(f) else break;
- end
- else
+ end;
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (didx <> mBucketsUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 1)');
+ {$ENDIF}
+ mFirstEntry := 0;
+ mLastEntry := mBucketsUsed-1;
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ cnt := 0;
+ for f := mFirstEntry to mLastEntry do
begin
- Inc(f);
+ if (mEntries[f].empty) then raise Exception.Create('internal error in hash table (invalid first/last range; 2)');
+ Inc(cnt);
end;
+ if (cnt <> mBucketsUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 3)');
+ if (cnt <> mEntriesUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 4)');
+ for f := mLastEntry+1 to High(mEntries) do
+ begin
+ if (not mEntries[f].empty) then raise Exception.Create('internal error in hash table (invalid first/last range; 5)');
+ end;
+ {$ENDIF}
+ end
+ else
+ begin
+ {$IFDEF RBHASH_SANITY_CHECKS}
+ if (mBucketsUsed <> 0) then raise Exception.Create('internal error in hash table (invalid bucket count; 1)');
+ {$ENDIF}
end;
// shrink
SetLength(mBuckets, newsz);
end;
+function THashBase.forEach (it: TIteratorFn): Boolean; overload;
+var
+ f: Integer;
+begin
+ result := false;
+ if not assigned(it) or (mFirstEntry < 0) then exit;
+ for f := mFirstEntry to mLastEntry do
+ begin
+ if (not mEntries[f].empty) then
+ begin
+ result := it(mEntries[f].key, mEntries[f].value);
+ if result then exit;
+ end;
+ end;
+end;
+
+function THashBase.forEach (it: TIteratorExFn): Boolean; overload;
+var
+ f: Integer;
+begin
+ result := false;
+ if not assigned(it) or (mFirstEntry < 0) then exit;
+ for f := mFirstEntry to mLastEntry do
+ begin
+ if (not mEntries[f].empty) then
+ begin
+ result := it(mEntries[f].key, mEntries[f].value, mEntries[f].hash);
+ if result then exit;
+ end;
+ end;
+end;
+
+
+// enumerators
+function THashBase.GetEnumerator (): TValEnumerator;
+begin
+ if (Length(mEntries) > 0) then result := TValEnumerator.Create(mEntries, mFirstEntry, mLastEntry)
+ else result := TValEnumerator.Create(nil, -1, -1);
+end;
+
+function THashBase.byKey (): TKeyEnumerator;
+begin
+ if (Length(mEntries) > 0) then result := TKeyEnumerator.Create(mEntries, mFirstEntry, mLastEntry)
+ else result := TKeyEnumerator.Create(nil, -1, -1);
+end;
+
+function THashBase.byValue (): TValEnumerator;
+begin
+ if (Length(mEntries) > 0) then result := TValEnumerator.Create(mEntries, mFirstEntry, mLastEntry)
+ else result := TValEnumerator.Create(nil, -1, -1);
+end;
+
+function THashBase.byKeyValue (): TKeyValEnumerator; // PEntry
+begin
+ if (Length(mEntries) > 0) then result := TKeyValEnumerator.Create(mEntries, mFirstEntry, mLastEntry)
+ else result := TKeyValEnumerator.Create(nil, -1, -1);
+end;
+
+
+function THashBase.TValEnumerator.GetEnumerator (): TValEnumerator; inline; begin result.mEntries := self.mEntries; result.mFirstEntry := self.mFirstEntry; result.mLastEntry := self.mLastEntry; result.cur := self.cur; end;
+function THashBase.TKeyEnumerator.GetEnumerator (): TKeyEnumerator; inline; begin result.mEntries := self.mEntries; result.mFirstEntry := self.mFirstEntry; result.mLastEntry := self.mLastEntry; result.cur := self.cur; end;
+function THashBase.TKeyValEnumerator.GetEnumerator (): TKeyValEnumerator; inline; begin result.mEntries := self.mEntries; result.mFirstEntry := self.mFirstEntry; result.mLastEntry := self.mLastEntry; result.cur := self.cur; end;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+constructor THashBase.TValEnumerator.Create (const aents: TEntryArray; afirst, alast: Integer);
+begin
+ mEntries := aents;
+ mFirstEntry := afirst;
+ mLastEntry := alast;
+ cur := mFirstEntry-1;
+end;
+
+function THashBase.TValEnumerator.MoveNext (): Boolean; inline;
+begin
+ Inc(cur);
+ while (cur <= mLastEntry) do
+ begin
+ if (not mEntries[cur].empty) then begin result := true; exit; end;
+ end;
+ result := false;
+end;
+
+function THashBase.TValEnumerator.getCurrent (): ValueT; inline;
+begin
+ result := mEntries[cur].value;
+end;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+constructor THashBase.TKeyEnumerator.Create (const aents: TEntryArray; afirst, alast: Integer);
+begin
+ mEntries := aents;
+ mFirstEntry := afirst;
+ mLastEntry := alast;
+ cur := mFirstEntry-1;
+end;
+
+function THashBase.TKeyEnumerator.MoveNext (): Boolean; inline;
+begin
+ Inc(cur);
+ while (cur <= mLastEntry) do
+ begin
+ if (not mEntries[cur].empty) then begin result := true; exit; end;
+ end;
+ result := false;
+end;
+
+function THashBase.TKeyEnumerator.getCurrent (): KeyT; inline;
+begin
+ result := mEntries[cur].key;
+end;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+constructor THashBase.TKeyValEnumerator.Create (const aents: TEntryArray; afirst, alast: Integer);
+begin
+ mEntries := aents;
+ mFirstEntry := afirst;
+ mLastEntry := alast;
+ cur := mFirstEntry-1;
+end;
+
+function THashBase.TKeyValEnumerator.MoveNext (): Boolean; inline;
+begin
+ Inc(cur);
+ while (cur <= mLastEntry) do
+ begin
+ if (not mEntries[cur].empty) then begin result := true; exit; end;
+ end;
+ result := false;
+end;
+
+function THashBase.TKeyValEnumerator.getCurrent (): PEntry; inline;
+begin
+ result := @mEntries[cur];
+end;
+
+
end.