X-Git-Url: https://deadsoftware.ru/gitweb?a=blobdiff_plain;f=src%2Fshared%2Fhashtable.pas;h=a51fc91d27519874d875a6b2799ab85b7230c599;hb=cde380b2a554f452f7c2e2c6694bc29ce597ece9;hp=955e599bf9f1ba6bb1516f2a5545362b82a6a37b;hpb=4e759d19749e8de5b7d1c8e8ca94a46cbabefae0;p=d2df-sdl.git diff --git a/src/shared/hashtable.pas b/src/shared/hashtable.pas index 955e599..a51fc91 100644 --- a/src/shared/hashtable.pas +++ b/src/shared/hashtable.pas @@ -19,7 +19,7 @@ {.$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; @@ -31,21 +31,68 @@ type // WARNING! don't put structures into hash, use ponters or ids! generic THashBase = 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; + 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 type PEntry = ^TEntry; TEntry = record + public key: KeyT; value: ValueT; + private hash: LongWord; // key hash or 0 - nextFree: Integer; + nextFree: PEntry; // next free entry + public + property keyhash: LongWord read hash; + end; + + private + 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 @@ -53,9 +100,12 @@ type equfn: TEquFn; 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 @@ -73,20 +123,34 @@ type 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 @@ -99,7 +163,7 @@ type 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 @@ -109,17 +173,28 @@ type type THashIntInt = specialize THashBase; + THashStrInt = specialize THashBase; + THashStrStr = specialize THashBase; function hashNewIntInt (): THashIntInt; +function hashNewStrInt (): THashStrInt; +function hashNewStrStr (): THashStrStr; 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): LongWord; function nextPOT (x: LongWord): LongWord; inline; +// for integer keys +function hiiequ (constref a, b: Integer): Boolean; +function hiihash (constref k: Integer): LongWord; +function hsiequ (constref a, b: AnsiString): Boolean; +function hsihash (constref k: AnsiString): LongWord; + + implementation uses @@ -145,12 +220,13 @@ end; // ////////////////////////////////////////////////////////////////////////// // function hiiequ (constref a, b: Integer): Boolean; begin result := (a = b); end; +function hsiequ (constref a, b: AnsiString): Boolean; begin result := (a = b); end; {$PUSH} {$RANGECHECKS OFF} function hiihash (constref k: Integer): LongWord; begin - result := k; + result := LongWord(k); result -= (result shl 6); result := result xor (result shr 17); result -= (result shl 9); @@ -159,6 +235,11 @@ begin result := result xor (result shl 10); result := result xor (result shr 15); end; + +function hsihash (constref k: AnsiString): LongWord; +begin + if (Length(k) > 0) then result := fnvHash(PAnsiChar(k)^, Length(k)) else result := 0; +end; {$POP} @@ -168,6 +249,18 @@ begin end; +function hashNewStrInt (): THashStrInt; +begin + result := THashStrInt.Create(hsihash, hsiequ); +end; + + +function hashNewStrStr (): THashStrStr; +begin + result := THashStrStr.Create(hsihash, hsiequ); +end; + + // ////////////////////////////////////////////////////////////////////////// // {$PUSH} {$RANGECHECKS OFF} @@ -190,7 +283,7 @@ begin end; -procedure TJoaatHasher.put (const buf; len: LongWord); +procedure TJoaatHasher.put (constref buf; len: LongWord); var bytes: PByte; h: LongWord; @@ -220,12 +313,12 @@ end; {$POP} -function joaatHash (const buf; len: LongWord): LongWord; +function joaatHash (constref buf; len: LongWord): LongWord; var h: TJoaatHasher; begin h := TJoaatHasher.Create(0); - h.put(buf, len); + h.put(PByte(@buf)^, len); result := h.value; end; @@ -234,7 +327,7 @@ end; {$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 @@ -289,39 +382,144 @@ begin 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)); + mBucketsUsed := 0; + {$IFDEF RBHASH_SANITY_CHECKS} + mEntriesUsed := 0; + {$ENDIF} + mFreeEntryHead := nil; //@mEntries[0]; + mFirstEntry := -1; + mLastEntry := -1; +end; + + +procedure THashBase.reset (); +var + idx: Integer; +begin + if (mBucketsUsed > 0) then + begin + for idx := 0 to High(mBuckets) do mBuckets[idx] := nil; + mBucketsUsed := 0; + {$IFDEF RBHASH_SANITY_CHECKS} + mEntriesUsed := 0; + {$ENDIF} + mFreeEntryHead := nil; //@mEntries[0]; + mFirstEntry := -1; + mLastEntry := -1; + end; +end; + + function THashBase.getCapacity (): Integer; inline; begin result := Length(mBuckets); end; function THashBase.allocEntry (): PEntry; +var + idx: Integer; begin + if (mFreeEntryHead = nil) then + begin + 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 (mFreeEntryHead.hash <> 0) 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.hash = 0) then raise Exception.Create('internal error in hash entry allocator (trying to release unallocated entry)'); {$ENDIF} - idx := LongWord((PtrUInt(e)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0])); + idx := Integer((PtrUInt(e)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0])); {$IFDEF RBHASH_SANITY_CHECKS} - if (idx >= Length(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid calculated index)'); + 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} + {$IFDEF RBHASH_SANITY_CHECKS} + Dec(mEntriesUsed); {$ENDIF} e.hash := 0; e.nextFree := mFreeEntryHead; - mFreeEntryHead := idx; - Dec(mEntriesUsed); + mFreeEntryHead := e; //idx; + // 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} + 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].hash = 0) 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].hash = 0) 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; @@ -332,31 +530,43 @@ begin 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 := hashfn(akey); + end + else + begin + khash := hashfn(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; + pdist := (mBuckets[idx].hash xor xseed) and bhigh; if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist); // if (dist > pdist) then break; @@ -367,34 +577,41 @@ begin 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 := hashfn(akey); + end + else + begin + khash := hashfn(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; + pdist := (mBuckets[idx].hash xor xseed) and bhigh; if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist); // 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; + if result then begin rval := mBuckets[idx].value; break; end; idx := (idx+1) and bhigh; end; @@ -406,10 +623,11 @@ procedure THashBase.putEntryInternal (swpe: PEntry); var idx, dist, pcur, pdist: LongWord; tmpe: PEntry; // current entry to swap (or nothing) - bhigh: LongWord; + 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 @@ -423,7 +641,7 @@ begin break; end; //pdist := distToStIdx(idx); - pdist := mBuckets[idx].hash and bhigh; + pdist := (mBuckets[idx].hash xor xseed) and bhigh; if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist); // if (pcur > pdist) then @@ -440,18 +658,21 @@ begin 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 := hashfn(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 @@ -460,7 +681,7 @@ begin begin if (mBuckets[idx] = nil) then break; //pdist := distToStIdx(idx); - pdist := mBuckets[idx].hash and bhigh; + pdist := (mBuckets[idx].hash xor xseed) and bhigh; if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist); // if (dist > pdist) then break; @@ -487,14 +708,12 @@ begin {$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 @@ -508,17 +727,29 @@ end; // 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 := hashfn(akey); + end + else + begin + khash := hashfn(akey); + end; + if (khash = 0) then khash := $29a; + + idx := (khash xor xseed) and bhigh; // find key if (mBuckets[idx] = nil) then exit; // no key @@ -526,7 +757,7 @@ begin begin if (mBuckets[idx] = nil) then break; //pdist := distToStIdx(idxcur); - pdist := mBuckets[idx].hash and bhigh; + pdist := (mBuckets[idx].hash xor xseed) and bhigh; if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist); // if (dist > pdist) then break; @@ -557,7 +788,7 @@ begin {$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; + pdist := (mBuckets[idxnext].hash xor xseed) and bhigh; if (pdist <= idxnext) then pdist := idxnext-pdist else pdist := idxnext+((bhigh+1)-pdist); // if (pdist = 0) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln(' pdist is zero');{$ENDIF} mBuckets[idx] := nil; break; end; @@ -571,89 +802,117 @@ begin 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; 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 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 + //e.hash := hashfn(e.key) xor mSeed; if (e.hash = 0) then e.hash := $29a; 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 e.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)); 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 + if (mFirstEntry >= 0) then begin - if (mEntries[f].hash <> 0) then + {$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 (mEntries[didx].hash <> 0) 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 (mEntries[f].hash <> 0) 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 (mEntries[didx].hash <> 0) 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].hash = 0) 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 (mEntries[f].hash <> 0) 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); @@ -664,4 +923,149 @@ begin end; +function THashBase.forEach (it: TIteratorFn): Boolean; overload; +var + i: Integer; +begin + result := false; + if not assigned(it) then exit; + i := mFirstEntry; + if (i < 0) then exit; + while (i <= mLastEntry) do + begin + if (mEntries[i].hash <> 0) then + begin + result := it(mEntries[i].key, mEntries[i].value); + if result then exit; + end; + Inc(i); + end; +end; + +function THashBase.forEach (it: TIteratorExFn): Boolean; overload; +var + i: Integer; +begin + result := false; + if not assigned(it) then exit; + i := mFirstEntry; + if (i < 0) then exit; + while (i <= mLastEntry) do + begin + if (mEntries[i].hash <> 0) then + begin + result := it(mEntries[i].key, mEntries[i].value, mEntries[i].hash); + if result then exit; + end; + Inc(i); + 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 (mEntries[cur].hash <> 0) 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 (mEntries[cur].hash <> 0) 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 (mEntries[cur].hash <> 0) then begin result := true; exit; end; + end; + result := false; +end; + +function THashBase.TKeyValEnumerator.getCurrent (): PEntry; inline; +begin + result := @mEntries[cur]; +end; + + end.