src/shared/hashtable.pas

   1 (* Copyright (C)  DooM 2D:Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, either version 3 of the License, or
   6  * (at your option) any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15  *)
  16 {$INCLUDE a_modes.inc}
  17 {.$DEFINE RBHASH_DEBUG_RESIZE}
  18 {.$DEFINE RBHASH_DEBUG_DELETE}
  19 {$IF DEFINED(D2F_DEBUG)}
  20   {$DEFINE RBHASH_SANITY_CHECKS}
  21 {$ENDIF}
  22 // hash table (robin hood)
  23 unit hashtable;
  24
  25 interface
  26
  27
  28 type
  29   // WARNING! don't put structures into hash, use ponters or ids!
  30   generic THashBase<KeyT, ValueT> = class(TObject)
  31   private
  32     const InitSize = {$IF DEFINED(D2F_DEBUG)}16{$ELSE}512{$ENDIF};
  33     const LoadFactorPrc = 90; // it is ok for robin hood hashes
  34
  35   public
  36     type THashFn = function (constref o: KeyT): LongWord;
  37     type TEquFn = function (constref a, b: KeyT): Boolean;
  38
  39   private
  40     type
  41       PEntry = ^TEntry;
  42       TEntry = record
  43         key: KeyT;
  44         value: ValueT;
  45         hash: LongWord; // key hash or 0
  46         nextFree: Integer;
  47       end;
  48
  49   private
  50     hashfn: THashFn;
  51     equfn: TEquFn;
  52     mBuckets: array of PEntry; // entries, points to mEntries elements
  53     mBucketsUsed: Integer;
  54     mEntries: array of TEntry;
  55     mEntriesUsed: Integer;
  56     mFreeEntryHead: Integer;
  57
  58   private
  59     function allocEntry (): PEntry;
  60     procedure releaseEntry (e: PEntry);
  61
  62     function distToStIdx (idx: LongWord): LongWord; inline;
  63
  64     procedure putEntryInternal (swpe: PEntry);
  65
  66   public
  67     constructor Create (ahashfn: THashFn; aequfn: TEquFn);
  68     destructor Destroy (); override;
  69
  70     procedure clear ();
  71
  72     procedure rehash ();
  73
  74     function get (constref akey: KeyT; out rval: ValueT): Boolean; // `true`: found
  75     function put (constref akey: KeyT; constref aval: ValueT): Boolean; // `true`: replaced
  76     function has (constref akey: KeyT): Boolean; // `true`: found
  77     function del (constref akey: KeyT): Boolean; // `true`: deleted
  78
  79     property count: Integer read mBucketsUsed;
  80   end;
  81
  82
  83 implementation
  84
  85 uses
  86   SysUtils;
  87
  88
  89 // ////////////////////////////////////////////////////////////////////////// //
  90 constructor THashBase.Create (ahashfn: THashFn; aequfn: TEquFn);
  91 begin
  92   if not assigned(ahashfn) then raise Exception.Create('cannot create hash without hash function');
  93   if not assigned(aequfn) then raise Exception.Create('cannot create hash without equality function');
  94
  95   hashfn := ahashfn;
  96   equfn := aequfn;
  97
  98   clear();
  99 end;
 100
 101
 102 destructor THashBase.Destroy ();
 103 begin
 104   mBuckets := nil;
 105   mEntries := nil;
 106   inherited;
 107 end;
 108
 109
 110 function THashBase.allocEntry (): PEntry;
 111 begin
 112   {$IFDEF RBHASH_SANITY_CHECKS}
 113   if (mFreeEntryHead = -1) then raise Exception.Create('internal error in hash entry allocator (0)');
 114   if (mEntries[mFreeEntryHead].hash <> 0) then raise Exception.Create('internal error in hash entry allocator (1)');
 115   {$ENDIF}
 116   result := @mEntries[mFreeEntryHead];
 117   mFreeEntryHead := result.nextFree;
 118   Inc(mEntriesUsed);
 119   result.nextFree := -1;
 120 end;
 121
 122
 123 procedure THashBase.releaseEntry (e: PEntry);
 124 var
 125   idx: LongWord;
 126 begin
 127   {$IFDEF RBHASH_SANITY_CHECKS}
 128   if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator');
 129   if (e = nil) then raise Exception.Create('internal error in hash entry allocator (trying to release nil entry)');
 130   if (e.nextFree <> -1) or (e.hash = 0) then raise Exception.Create('internal error in hash entry allocator (trying to release unallocated entry)');
 131   {$ENDIF}
 132   idx := LongWord((PtrUInt(e)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0]));
 133   {$IFDEF RBHASH_SANITY_CHECKS}
 134   if (idx >= Length(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid calculated index)');
 135   {$ENDIF}
 136   e.hash := 0;
 137   e.nextFree := mFreeEntryHead;
 138   mFreeEntryHead := idx;
 139   Dec(mEntriesUsed);
 140 end;
 141
 142
 143 function THashBase.distToStIdx (idx: LongWord): LongWord; inline;
 144 var
 145   stidx: LongWord;
 146 begin
 147   {$IFDEF RBHASH_SANITY_CHECKS}
 148   assert(idx < Length(mBuckets));
 149   assert(mBuckets[idx] <> nil);
 150   {$ENDIF}
 151   stidx := mBuckets[idx].hash mod Length(mBuckets);
 152   if (stidx <= idx) then result := idx-stidx else result := idx+(Length(mBuckets)-stidx);
 153 end;
 154
 155
 156 function THashBase.has (constref akey: KeyT): Boolean;
 157 var
 158   khash, idx: LongWord;
 159   dist, pdist: LongWord;
 160   blen: LongWord;
 161 begin
 162   result := false;
 163   if (mBucketsUsed = 0) then exit;
 164
 165   blen := Length(mBuckets);
 166   khash := hashfn(akey); if (khash = 0) then khash := $29a;
 167   idx := khash mod blen;
 168   if (mBuckets[idx] = nil) then exit;
 169
 170   for dist := 0 to blen-1 do
 171   begin
 172     if (mBuckets[idx] = nil) then break;
 173     pdist := distToStIdx(idx);
 174     if (dist > pdist) then break;
 175     result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 176     if result then break;
 177     idx := (idx+1) mod blen;
 178   end;
 179 end;
 180
 181
 182 function THashBase.get (constref akey: KeyT; out rval: ValueT): Boolean;
 183 var
 184   khash, idx: LongWord;
 185   dist, pdist: LongWord;
 186   blen: LongWord;
 187 begin
 188   result := false;
 189   if (mBucketsUsed = 0) then begin rval := Default(ValueT); exit; end;
 190
 191   blen := Length(mBuckets);
 192   khash := hashfn(akey); if (khash = 0) then khash := $29a;
 193   idx := khash mod blen;
 194   if (mBuckets[idx] = nil) then begin rval := Default(ValueT); exit; end;
 195
 196   for dist := 0 to blen-1 do
 197   begin
 198     if (mBuckets[idx] = nil) then break;
 199     pdist := distToStIdx(idx);
 200     if (dist > pdist) then break;
 201     result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 202     if result then
 203     begin
 204       rval := mBuckets[idx].value;
 205       break;
 206     end;
 207     idx := (idx+1) mod blen;
 208   end;
 209
 210   if not result then rval := Default(ValueT); // just in case
 211 end;
 212
 213
 214 procedure THashBase.putEntryInternal (swpe: PEntry);
 215 var
 216   idx, dist, pcur, pdist: LongWord;
 217   tmpe: PEntry; // current entry to swap (or nothing)
 218   blen: LongWord;
 219 begin
 220   blen := Length(mBuckets);
 221   idx := swpe.hash mod blen;
 222   pcur := 0;
 223   for dist := 0 to blen-1 do
 224   begin
 225     if (mBuckets[idx] = nil) then
 226     begin
 227       // put entry
 228       mBuckets[idx] := swpe;
 229       Inc(mBucketsUsed);
 230       break;
 231     end;
 232     pdist := distToStIdx(idx);
 233     if (pcur > pdist) then
 234     begin
 235       // swapping the current bucket with the one to insert
 236       tmpe := mBuckets[idx];
 237       mBuckets[idx] := swpe;
 238       swpe := tmpe;
 239       pcur := pdist;
 240     end;
 241     idx := (idx+1) mod blen;
 242     Inc(pcur);
 243   end;
 244 end;
 245
 246
 247 function THashBase.put (constref akey: KeyT; constref aval: ValueT): Boolean;
 248 var
 249   khash, stidx, idx, dist, pdist: LongWord;
 250   swpe: PEntry = nil; // current entry to swap (or nothing)
 251   blen: LongWord;
 252   newsz, eidx: Integer;
 253 begin
 254   result := false;
 255
 256   blen := Length(mBuckets);
 257   khash := hashfn(akey); if (khash = 0) then khash := $29a;
 258   stidx := khash mod blen;
 259
 260   // check if we already have this key
 261   idx := stidx;
 262   if (mBucketsUsed <> 0) and (mBuckets[idx] <> nil) then
 263   begin
 264     for dist := 0 to blen-1 do
 265     begin
 266       if (mBuckets[idx] = nil) then break;
 267       pdist := distToStIdx(idx);
 268       if (dist > pdist) then break;
 269       result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 270       if result then
 271       begin
 272         // replace element
 273         //mBuckets[idx].key := akey;
 274         mBuckets[idx].value := aval;
 275         exit;
 276       end;
 277       idx := (idx+1) mod blen;
 278     end;
 279   end;
 280
 281   // need to resize hash?
 282   if (mBucketsUsed >= blen*LoadFactorPrc div 100) then
 283   begin
 284     newsz := Length(mBuckets);
 285     if (Length(mEntries) <> newsz) then raise Exception.Create('internal error in hash table (resize)');
 286     if (newsz <= 1024*1024*1024) then newsz *= 2 else raise Exception.Create('hash table too big');
 287     {$IFDEF RBHASH_DEBUG_RESIZE}
 288     writeln('resizing hash; used=', mBucketsUsed, '; total=', blen, '; maxload=', blen*LoadFactorPrc div 100, '; newsz=', newsz);
 289     {$ENDIF}
 290     SetLength(mBuckets, newsz);
 291     // resize entries array
 292     eidx := newsz;
 293     SetLength(mEntries, newsz);
 294     while (eidx < Length(mEntries)) do begin mEntries[eidx].hash := 0; Inc(eidx); end;
 295     // mFreeEntryHead will be fixed in `rehash()`
 296     // reinsert entries
 297     rehash();
 298   end;
 299
 300   // create new entry
 301   swpe := allocEntry();
 302   swpe.key := akey;
 303   swpe.value := aval;
 304   swpe.hash := khash;
 305
 306   putEntryInternal(swpe);
 307 end;
 308
 309
 310 // see http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
 311 function THashBase.del (constref akey: KeyT): Boolean;
 312 var
 313   khash, stidx, idxcur, idxnext, pdist, dist: LongWord;
 314   blen: LongWord;
 315 begin
 316   result := false;
 317   if (mBucketsUsed = 0) then exit;
 318
 319   blen := Length(mBuckets);
 320   khash := hashfn(akey); if (khash = 0) then khash := $29a;
 321   stidx := khash mod blen;
 322
 323   // find key
 324   if (mBuckets[stidx] = nil) then exit; // no key
 325
 326   idxcur := stidx;
 327   for dist := 0 to blen-1 do
 328   begin
 329     if (mBuckets[idxcur] = nil) then break;
 330     pdist := distToStIdx(idxcur);
 331     if (dist > pdist) then break;
 332     result := (mBuckets[idxcur].hash = khash) and equfn(mBuckets[idxcur].key, akey);
 333     if result then break;
 334     idxcur := (idxcur+1) mod blen;
 335   end;
 336
 337   if not result then
 338   begin
 339     // key not found
 340     {$IFDEF RBHASH_DEBUG_DELETE}
 341     writeln('del: key ', akey, ': not found');
 342     {$ENDIF}
 343     exit;
 344   end;
 345
 346   {$IFDEF RBHASH_DEBUG_DELETE}
 347   writeln('del: key ', akey, ': found at ', idxcur, '(', stidx, '); ek=', mBuckets[idxcur].key, '; ev=', mBuckets[idxcur].value);
 348   {$ENDIF}
 349   releaseEntry(mBuckets[idxcur]);
 350
 351   idxnext := (idxcur+1) mod blen;
 352   for dist := 0 to blen-1 do
 353   begin
 354     {$IFDEF RBHASH_DEBUG_DELETE}
 355     writeln(' dist=', dist, '; idxcur=', idxcur, '; idxnext=', idxnext, '; ce=', (mBuckets[idxcur] <> nil), '; ne=', (mBuckets[idxnext] <> nil));
 356     {$ENDIF}
 357     if (mBuckets[idxnext] = nil) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln('  idxnext nil');{$ENDIF} mBuckets[idxcur] := nil; break; end;
 358     pdist := distToStIdx(idxnext);
 359     if (pdist = 0) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln('  pdist is zero');{$ENDIF} mBuckets[idxcur] := nil; break; end;
 360     {$IFDEF RBHASH_DEBUG_DELETE}writeln('  pdist=', pdist);{$ENDIF}
 361     mBuckets[idxcur] := mBuckets[idxnext];
 362     idxcur := (idxcur+1) mod blen;
 363     idxnext := (idxnext+1) mod blen;
 364   end;
 365
 366   Dec(mBucketsUsed);
 367 end;
 368
 369
 370 procedure THashBase.clear ();
 371 var
 372   idx: Integer;
 373 begin
 374   SetLength(mBuckets, InitSize);
 375   for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
 376
 377   SetLength(mEntries, Length(mBuckets));
 378   for idx := 0 to High(mEntries) do
 379   begin
 380     mEntries[idx].hash := 0;
 381     mEntries[idx].nextFree := idx+1;
 382   end;
 383   mEntries[High(mEntries)].nextFree := -1;
 384
 385   mBucketsUsed := 0;
 386   mEntriesUsed := 0;
 387   mFreeEntryHead := 0;
 388 end;
 389
 390
 391 procedure THashBase.rehash ();
 392 var
 393   idx, lastfree: Integer;
 394   e: PEntry;
 395 begin
 396   // clear buckets
 397   for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
 398   mBucketsUsed := 0;
 399   // reinsert entries
 400   mFreeEntryHead := -1;
 401   lastfree := -1;
 402   for idx := 0 to High(mEntries) do
 403   begin
 404     e := @mEntries[idx];
 405     if (e.hash <> 0) then
 406     begin
 407       putEntryInternal(e);
 408     end
 409     else
 410     begin
 411       if (lastfree <> -1) then mEntries[lastfree].nextFree := idx else mFreeEntryHead := idx;
 412       lastfree := idx;
 413     end;
 414   end;
 415 end;
 416
 417
 418 end.