added robin hood hash table implementation

diff --git a/src/game/Doom2DF.dpr b/src/game/Doom2DF.dpr
index 26fd58b6f710824959569c7b5f9c7240797f64e9..1341a798d0a8d27cfef71b5705bbef7387a42a61 100644 (file)
--- a/src/game/Doom2DF.dpr
+++ b/src/game/Doom2DF.dpr
@@ -99,6 +99,7 @@ uses
 {$ENDIF}
   xprofiler in '../shared/xprofiler.pas',
   binheap in '../shared/binheap.pas',
+  hashtable in '../shared/hashtable.pas',
   BinEditor in '../shared/BinEditor.pas',
   envvars in '../shared/envvars.pas',
   g_panel in 'g_panel.pas',

diff --git a/src/shared/a_modes.inc b/src/shared/a_modes.inc
index 9c5c74c08774122fa8a2e705e89f63d449807b3a..9d1da17825a7b8580b5ed4239eaeaca7a4619060 100644 (file)
--- a/src/shared/a_modes.inc
+++ b/src/shared/a_modes.inc
@@ -55,6 +55,7 @@
 {$MMX-} // get lost, mmx
 
 {$IF DEFINED(D2F_DEBUG)}
+  {$RANGECHECKS ON}
   {$STACKFRAMES ON}
 {$ELSE}
   {$STACKFRAMES OFF}

diff --git a/src/shared/hashtable.pas b/src/shared/hashtable.pas
new file mode 100644 (file)
index 0000000..8b75d54
--- /dev/null
+++ b/src/shared/hashtable.pas
@@ -0,0 +1,418 @@
+(* 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.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program.  If not, see <http://www.gnu.org/licenses/>.
+ *)
+{$INCLUDE a_modes.inc}
+{.$DEFINE RBHASH_DEBUG_RESIZE}
+{.$DEFINE RBHASH_DEBUG_DELETE}
+{$IF DEFINED(D2F_DEBUG)}
+  {$DEFINE RBHASH_SANITY_CHECKS}
+{$ENDIF}
+// hash table (robin hood)
+unit hashtable;
+
+interface
+
+
+type
+  // WARNING! don't put structures into hash, use ponters or ids!
+  generic THashBase<KeyT, ValueT> = class(TObject)
+  private
+    const InitSize = {$IF DEFINED(D2F_DEBUG)}16{$ELSE}512{$ENDIF};
+    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
+        key: KeyT;
+        value: ValueT;
+        hash: LongWord; // key hash or 0
+        nextFree: Integer;
+      end;
+
+  private
+    hashfn: THashFn;
+    equfn: TEquFn;
+    mBuckets: array of PEntry; // entries, points to mEntries elements
+    mBucketsUsed: Integer;
+    mEntries: array of TEntry;
+    mEntriesUsed: Integer;
+    mFreeEntryHead: Integer;
+
+  private
+    function allocEntry (): PEntry;
+    procedure releaseEntry (e: PEntry);
+
+    function distToStIdx (idx: LongWord): LongWord; inline;
+
+    procedure putEntryInternal (swpe: PEntry);
+
+  public
+    constructor Create (ahashfn: THashFn; aequfn: TEquFn);
+    destructor Destroy (); override;
+
+    procedure clear ();
+
+    procedure rehash ();
+
+    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
+
+    property count: Integer read mBucketsUsed;
+  end;
+
+
+implementation
+
+uses
+  SysUtils;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+constructor THashBase.Create (ahashfn: THashFn; aequfn: TEquFn);
+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');
+
+  hashfn := ahashfn;
+  equfn := aequfn;
+
+  clear();
+end;
+
+
+destructor THashBase.Destroy ();
+begin
+  mBuckets := nil;
+  mEntries := nil;
+  inherited;
+end;
+
+
+function THashBase.allocEntry (): PEntry;
+begin
+  {$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)');
+  {$ENDIF}
+  result := @mEntries[mFreeEntryHead];
+  mFreeEntryHead := result.nextFree;
+  Inc(mEntriesUsed);
+  result.nextFree := -1;
+end;
+
+
+procedure THashBase.releaseEntry (e: PEntry);
+var
+  idx: LongWord;
+begin
+  {$IFDEF RBHASH_SANITY_CHECKS}
+  if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator');
+  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)');
+  {$ENDIF}
+  idx := LongWord((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)');
+  {$ENDIF}
+  e.hash := 0;
+  e.nextFree := mFreeEntryHead;
+  mFreeEntryHead := idx;
+  Dec(mEntriesUsed);
+end;
+
+
+function THashBase.distToStIdx (idx: LongWord): LongWord; inline;
+var
+  stidx: LongWord;
+begin
+  {$IFDEF RBHASH_SANITY_CHECKS}
+  assert(idx < Length(mBuckets));
+  assert(mBuckets[idx] <> nil);
+  {$ENDIF}
+  stidx := mBuckets[idx].hash mod Length(mBuckets);
+  if (stidx <= idx) then result := idx-stidx else result := idx+(Length(mBuckets)-stidx);
+end;
+
+
+function THashBase.has (constref akey: KeyT): Boolean;
+var
+  khash, idx: LongWord;
+  dist, pdist: LongWord;
+  blen: LongWord;
+begin
+  result := false;
+  if (mBucketsUsed = 0) then exit;
+
+  blen := Length(mBuckets);
+  khash := hashfn(akey); if (khash = 0) then khash := $29a;
+  idx := khash mod blen;
+  if (mBuckets[idx] = nil) then exit;
+
+  for dist := 0 to blen-1 do
+  begin
+    if (mBuckets[idx] = nil) then break;
+    pdist := distToStIdx(idx);
+    if (dist > pdist) then break;
+    result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
+    if result then break;
+    idx := (idx+1) mod blen;
+  end;
+end;
+
+
+function THashBase.get (constref akey: KeyT; out rval: ValueT): Boolean;
+var
+  khash, idx: LongWord;
+  dist, pdist: LongWord;
+  blen: LongWord;
+begin
+  result := false;
+  if (mBucketsUsed = 0) then begin rval := Default(ValueT); exit; end;
+
+  blen := Length(mBuckets);
+  khash := hashfn(akey); if (khash = 0) then khash := $29a;
+  idx := khash mod blen;
+  if (mBuckets[idx] = nil) then begin rval := Default(ValueT); exit; end;
+
+  for dist := 0 to blen-1 do
+  begin
+    if (mBuckets[idx] = nil) then break;
+    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;
+    idx := (idx+1) mod blen;
+  end;
+
+  if not result then rval := Default(ValueT); // just in case
+end;
+
+
+procedure THashBase.putEntryInternal (swpe: PEntry);
+var
+  idx, dist, pcur, pdist: LongWord;
+  tmpe: PEntry; // current entry to swap (or nothing)
+  blen: LongWord;
+begin
+  blen := Length(mBuckets);
+  idx := swpe.hash mod blen;
+  pcur := 0;
+  for dist := 0 to blen-1 do
+  begin
+    if (mBuckets[idx] = nil) then
+    begin
+      // put entry
+      mBuckets[idx] := swpe;
+      Inc(mBucketsUsed);
+      break;
+    end;
+    pdist := distToStIdx(idx);
+    if (pcur > pdist) then
+    begin
+      // swapping the current bucket with the one to insert
+      tmpe := mBuckets[idx];
+      mBuckets[idx] := swpe;
+      swpe := tmpe;
+      pcur := pdist;
+    end;
+    idx := (idx+1) mod blen;
+    Inc(pcur);
+  end;
+end;
+
+
+function THashBase.put (constref akey: KeyT; constref aval: ValueT): Boolean;
+var
+  khash, stidx, idx, dist, pdist: LongWord;
+  swpe: PEntry = nil; // current entry to swap (or nothing)
+  blen: LongWord;
+  newsz, eidx: Integer;
+begin
+  result := false;
+
+  blen := Length(mBuckets);
+  khash := hashfn(akey); if (khash = 0) then khash := $29a;
+  stidx := khash mod blen;
+
+  // check if we already have this key
+  idx := stidx;
+  if (mBucketsUsed <> 0) and (mBuckets[idx] <> nil) then
+  begin
+    for dist := 0 to blen-1 do
+    begin
+      if (mBuckets[idx] = nil) then break;
+      pdist := distToStIdx(idx);
+      if (dist > pdist) then break;
+      result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
+      if result then
+      begin
+        // replace element
+        //mBuckets[idx].key := akey;
+        mBuckets[idx].value := aval;
+        exit;
+      end;
+      idx := (idx+1) mod blen;
+    end;
+  end;
+
+  // need to resize hash?
+  if (mBucketsUsed >= blen*LoadFactorPrc div 100) then
+  begin
+    newsz := Length(mBuckets);
+    if (Length(mEntries) <> newsz) then raise Exception.Create('internal error in hash table (resize)');
+    if (newsz <= 1024*1024*512) then newsz *= 2 else newsz += 1024*1024;
+    {$IFDEF RBHASH_DEBUG_RESIZE}
+    writeln('resizing hash; used=', mBucketsUsed, '; total=', blen, '; maxload=', blen*LoadFactorPrc div 100, '; newsz=', newsz);
+    {$ENDIF}
+    SetLength(mBuckets, newsz);
+    // resize entries array
+    eidx := newsz;
+    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();
+  end;
+
+  // create new entry
+  swpe := allocEntry();
+  swpe.key := akey;
+  swpe.value := aval;
+  swpe.hash := khash;
+
+  putEntryInternal(swpe);
+end;
+
+
+// see http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
+function THashBase.del (constref akey: KeyT): Boolean;
+var
+  khash, stidx, idxcur, idxnext, pdist, dist: LongWord;
+  blen: LongWord;
+begin
+  result := false;
+  if (mBucketsUsed = 0) then exit;
+
+  blen := Length(mBuckets);
+  khash := hashfn(akey); if (khash = 0) then khash := $29a;
+  stidx := khash mod blen;
+
+  // find key
+  if (mBuckets[stidx] = nil) then exit; // no key
+
+  idxcur := stidx;
+  for dist := 0 to blen-1 do
+  begin
+    if (mBuckets[idxcur] = nil) then break;
+    pdist := distToStIdx(idxcur);
+    if (dist > pdist) then break;
+    result := (mBuckets[idxcur].hash = khash) and equfn(mBuckets[idxcur].key, akey);
+    if result then break;
+    idxcur := (idxcur+1) mod blen;
+  end;
+
+  if not result then
+  begin
+    // key not found
+    {$IFDEF RBHASH_DEBUG_DELETE}
+    writeln('del: key ', akey, ': not found');
+    {$ENDIF}
+    exit;
+  end;
+
+  {$IFDEF RBHASH_DEBUG_DELETE}
+  writeln('del: key ', akey, ': found at ', idxcur, '(', stidx, '); ek=', mBuckets[idxcur].key, '; ev=', mBuckets[idxcur].value);
+  {$ENDIF}
+  releaseEntry(mBuckets[idxcur]);
+
+  idxnext := (idxcur+1) mod blen;
+  for dist := 0 to blen-1 do
+  begin
+    {$IFDEF RBHASH_DEBUG_DELETE}
+    writeln(' dist=', dist, '; idxcur=', idxcur, '; idxnext=', idxnext, '; ce=', (mBuckets[idxcur] <> nil), '; ne=', (mBuckets[idxnext] <> nil));
+    {$ENDIF}
+    if (mBuckets[idxnext] = nil) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln('  idxnext nil');{$ENDIF} mBuckets[idxcur] := nil; break; end;
+    pdist := distToStIdx(idxnext);
+    if (pdist = 0) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln('  pdist is zero');{$ENDIF} mBuckets[idxcur] := nil; break; end;
+    {$IFDEF RBHASH_DEBUG_DELETE}writeln('  pdist=', pdist);{$ENDIF}
+    mBuckets[idxcur] := mBuckets[idxnext];
+    idxcur := (idxcur+1) mod blen;
+    idxnext := (idxnext+1) mod blen;
+  end;
+
+  Dec(mBucketsUsed);
+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;
+begin
+  // clear buckets
+  for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
+  mBucketsUsed := 0;
+  // reinsert entries
+  mFreeEntryHead := -1;
+  lastfree := -1;
+  for idx := 0 to High(mEntries) do
+  begin
+    e := @mEntries[idx];
+    if (e.hash <> 0) then
+    begin
+      putEntryInternal(e);
+    end
+    else
+    begin
+      if (lastfree <> -1) then mEntries[lastfree].nextFree := idx else mFreeEntryHead := idx;
+      lastfree := idx;
+    end;
+  end;
+end;
+
+
+end.