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_INSERT}
  19 {.$DEFINE RBHASH_DEBUG_DELETE}
  20 {.$DEFINE RBHASH_DEBUG_COMPACT}
  21 {$IF DEFINED(D2F_DEBUG)}
  22   {$DEFINE RBHASH_SANITY_CHECKS}
  23 {$ENDIF}
  24 // hash table (robin hood)
  25 unit hashtable;
  26
  27 interface
  28
  29
  30 type
  31   // WARNING! don't put structures into hash, use ponters or ids!
  32   generic THashBase<KeyT, ValueT> = class(TObject)
  33   private
  34     const InitSize = {$IF DEFINED(D2F_DEBUG)}16{$ELSE}512{$ENDIF}; // *MUST* be power of two
  35     const LoadFactorPrc = 90; // it is ok for robin hood hashes
  36
  37   public
  38     type THashFn = function (constref o: KeyT): LongWord;
  39     type TEquFn = function (constref a, b: KeyT): Boolean;
  40     type TIteratorFn = function (constref k: KeyT; constref v: ValueT): Boolean is nested; // return `true` to stop
  41
  42   private
  43     type
  44       PEntry = ^TEntry;
  45       TEntry = record
  46         key: KeyT;
  47         value: ValueT;
  48         hash: LongWord; // key hash or 0
  49         nextFree: PEntry; // next free entry
  50       end;
  51
  52   private
  53     hashfn: THashFn;
  54     equfn: TEquFn;
  55     mBuckets: array of PEntry; // entries, points to mEntries elements
  56     mBucketsUsed: Integer;
  57     mEntries: array of TEntry;
  58     {$IFDEF RBHASH_SANITY_CHECKS}
  59     mEntriesUsed: Integer;
  60     {$ENDIF}
  61     mFreeEntryHead: PEntry;
  62     mFirstEntry, mLastEntry: Integer;
  63     mSeed: LongWord;
  64
  65   private
  66     function allocEntry (): PEntry;
  67     procedure releaseEntry (e: PEntry);
  68
  69     //function distToStIdx (idx: LongWord): LongWord; inline;
  70
  71     procedure putEntryInternal (swpe: PEntry);
  72
  73     function getCapacity (): Integer; inline;
  74
  75   public
  76     constructor Create (ahashfn: THashFn; aequfn: TEquFn);
  77     destructor Destroy (); override;
  78
  79     procedure clear ();
  80     procedure reset (); // don't shrink buckets
  81
  82     procedure rehash ();
  83     procedure compact (); // call this instead of `rehash()` after alot of deletions
  84
  85     function get (constref akey: KeyT; out rval: ValueT): Boolean; // `true`: found
  86     function put (constref akey: KeyT; constref aval: ValueT): Boolean; // `true`: replaced
  87     function has (constref akey: KeyT): Boolean; // `true`: found
  88     function del (constref akey: KeyT): Boolean; // `true`: deleted
  89
  90     //WARNING! don't modify table in iterator (queries are ok, though)
  91     function forEach (it: TIteratorFn): Boolean;
  92
  93     property count: Integer read mBucketsUsed;
  94     property capacity: Integer read getCapacity;
  95   end;
  96
  97
  98 type
  99   TJoaatHasher = record
 100   private
 101     seed: LongWord; // initial seed value; MUST BE FIRST
 102     hash: LongWord; // current value
 103
 104   public
 105     constructor Create (aseed: LongWord);
 106
 107     procedure reset (); inline; overload;
 108     procedure reset (aseed: LongWord); inline; overload;
 109
 110     procedure put (const buf; len: LongWord);
 111
 112     // current hash value
 113     // you can continue putting data, as this is not destructive
 114     function value: LongWord; inline;
 115   end;
 116
 117
 118 type
 119   THashIntInt = specialize THashBase<Integer, Integer>;
 120
 121 function hashNewIntInt (): THashIntInt;
 122
 123
 124 function u32Hash (a: LongWord): LongWord; inline;
 125 function fnvHash (const buf; len: LongWord): LongWord;
 126 function joaatHash (const buf; len: LongWord): LongWord;
 127
 128 function nextPOT (x: LongWord): LongWord; inline;
 129
 130
 131 implementation
 132
 133 uses
 134   SysUtils;
 135
 136
 137 // ////////////////////////////////////////////////////////////////////////// //
 138 {$PUSH}
 139 {$RANGECHECKS OFF}
 140 function nextPOT (x: LongWord): LongWord; inline;
 141 begin
 142   result := x;
 143   result := result or (result shr 1);
 144   result := result or (result shr 2);
 145   result := result or (result shr 4);
 146   result := result or (result shr 8);
 147   result := result or (result shr 16);
 148   // already pot?
 149   if (x <> 0) and ((x and (x-1)) = 0) then result := result and (not (result shr 1)) else result += 1;
 150 end;
 151 {$POP}
 152
 153
 154 // ////////////////////////////////////////////////////////////////////////// //
 155 function hiiequ (constref a, b: Integer): Boolean; begin result := (a = b); end;
 156
 157 {$PUSH}
 158 {$RANGECHECKS OFF}
 159 function hiihash (constref k: Integer): LongWord;
 160 begin
 161   result := k;
 162   result -= (result shl 6);
 163   result := result xor (result shr 17);
 164   result -= (result shl 9);
 165   result := result xor (result shl 4);
 166   result -= (result shl 3);
 167   result := result xor (result shl 10);
 168   result := result xor (result shr 15);
 169 end;
 170 {$POP}
 171
 172
 173 function hashNewIntInt (): THashIntInt;
 174 begin
 175   result := THashIntInt.Create(hiihash, hiiequ);
 176 end;
 177
 178
 179 // ////////////////////////////////////////////////////////////////////////// //
 180 {$PUSH}
 181 {$RANGECHECKS OFF}
 182 constructor TJoaatHasher.Create (aseed: LongWord);
 183 begin
 184   reset(aseed);
 185 end;
 186
 187
 188 procedure TJoaatHasher.reset (); inline; overload;
 189 begin
 190   hash := seed;
 191 end;
 192
 193
 194 procedure TJoaatHasher.reset (aseed: LongWord); inline; overload;
 195 begin
 196   seed := aseed;
 197   hash := aseed;
 198 end;
 199
 200
 201 procedure TJoaatHasher.put (const buf; len: LongWord);
 202 var
 203   bytes: PByte;
 204   h: LongWord;
 205 begin
 206   if (len < 1) then exit;
 207   bytes := PByte(@buf);
 208   h := hash;
 209   while (len > 0) do
 210   begin
 211     h += bytes^;
 212     h += (h shl 10);
 213     h := h xor (h shr 6);
 214     Dec(len);
 215     Inc(bytes);
 216   end;
 217   hash := h;
 218 end;
 219
 220
 221 function TJoaatHasher.value: LongWord; inline;
 222 begin
 223   result := hash;
 224   result += (result shl 3);
 225   result := result xor (result shr 11);
 226   result += (result shl 15);
 227 end;
 228 {$POP}
 229
 230
 231 function joaatHash (const buf; len: LongWord): LongWord;
 232 var
 233   h: TJoaatHasher;
 234 begin
 235   h := TJoaatHasher.Create(0);
 236   h.put(buf, len);
 237   result := h.value;
 238 end;
 239
 240
 241 // ////////////////////////////////////////////////////////////////////////// //
 242 {$PUSH}
 243 {$RANGECHECKS OFF}
 244 // fnv-1a: http://www.isthe.com/chongo/tech/comp/fnv/
 245 function fnvHash (const buf; len: LongWord): LongWord;
 246 var
 247   b: PByte;
 248 begin
 249   b := @buf;
 250   result := 2166136261; // fnv offset basis
 251   while (len > 0) do
 252   begin
 253     result := result xor b^;
 254     result := result*16777619; // 32-bit fnv prime
 255     Inc(b);
 256     Dec(len);
 257   end;
 258 end;
 259 {$POP}
 260
 261
 262 {$PUSH}
 263 {$RANGECHECKS OFF}
 264 function u32Hash (a: LongWord): LongWord; inline;
 265 begin
 266   result := a;
 267   result -= (result shl 6);
 268   result := result xor (result shr 17);
 269   result -= (result shl 9);
 270   result := result xor (result shl 4);
 271   result -= (result shl 3);
 272   result := result xor (result shl 10);
 273   result := result xor (result shr 15);
 274 end;
 275 {$POP}
 276
 277
 278 // ////////////////////////////////////////////////////////////////////////// //
 279 constructor THashBase.Create (ahashfn: THashFn; aequfn: TEquFn);
 280 begin
 281   if not assigned(ahashfn) then raise Exception.Create('cannot create hash without hash function');
 282   if not assigned(aequfn) then raise Exception.Create('cannot create hash without equality function');
 283
 284   hashfn := ahashfn;
 285   equfn := aequfn;
 286   mSeed := u32Hash($29a);
 287
 288   clear();
 289 end;
 290
 291
 292 destructor THashBase.Destroy ();
 293 begin
 294   mBuckets := nil;
 295   mEntries := nil;
 296   inherited;
 297 end;
 298
 299
 300 procedure THashBase.clear ();
 301 var
 302   idx: Integer;
 303 begin
 304   SetLength(mBuckets, InitSize);
 305   for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
 306
 307   SetLength(mEntries, Length(mBuckets));
 308   {
 309   for idx := 0 to High(mEntries)-1 do
 310   begin
 311     mEntries[idx].hash := 0;
 312     mEntries[idx].nextFree := @mEntries[idx+1]; //idx+1;
 313   end;
 314   mEntries[High(mEntries)].hash := 0;
 315   mEntries[High(mEntries)].nextFree := nil;
 316   }
 317   {
 318   for idx := 0 to High(mEntries) do
 319   begin
 320     mEntries[idx].hash := 0;
 321     mEntries[idx].nextFree := nil;
 322   end;
 323   }
 324
 325   mBucketsUsed := 0;
 326   {$IFDEF RBHASH_SANITY_CHECKS}
 327   mEntriesUsed := 0;
 328   {$ENDIF}
 329   mFreeEntryHead := nil; //@mEntries[0];
 330   mFirstEntry := -1;
 331   mLastEntry := -1;
 332 end;
 333
 334
 335 procedure THashBase.reset ();
 336 var
 337   idx: Integer;
 338 begin
 339   if (mBucketsUsed > 0) then
 340   begin
 341     for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
 342     {
 343     for idx := 0 to High(mEntries)-1 do
 344     begin
 345       mEntries[idx].hash := 0;
 346       mEntries[idx].nextFree := @mEntries[idx+1]; //idx+1;
 347     end;
 348     mEntries[High(mEntries)].hash := 0;
 349     mEntries[High(mEntries)].nextFree := nil;
 350     }
 351     {
 352     if (mFirstEntry >= 0) then
 353     begin
 354       for idx := mFirstEntry to mLastEntry do
 355       begin
 356         mEntries[idx].hash := 0;
 357         mEntries[idx].nextFree := nil;
 358       end;
 359     end;
 360     }
 361
 362     mBucketsUsed := 0;
 363     {$IFDEF RBHASH_SANITY_CHECKS}
 364     mEntriesUsed := 0;
 365     {$ENDIF}
 366     mFreeEntryHead := nil; //@mEntries[0];
 367     mFirstEntry := -1;
 368     mLastEntry := -1;
 369   end;
 370 end;
 371
 372
 373 function THashBase.getCapacity (): Integer; inline; begin result := Length(mBuckets); end;
 374
 375
 376 function THashBase.allocEntry (): PEntry;
 377 var
 378   idx: Integer;
 379 begin
 380   if (mFreeEntryHead = nil) then
 381   begin
 382     if (mLastEntry = High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (0.0)');
 383     Inc(mLastEntry);
 384     if (mFirstEntry = -1) then
 385     begin
 386       if (mLastEntry <> 0) then raise Exception.Create('internal error in hash entry allocator (0.1)');
 387       mFirstEntry := 0;
 388     end;
 389     result := @mEntries[mLastEntry];
 390     result.nextFree := nil; // just in case
 391     {$IFDEF RBHASH_SANITY_CHECKS}
 392     Inc(mEntriesUsed);
 393     {$ENDIF}
 394     exit;
 395   end;
 396   {$IFDEF RBHASH_SANITY_CHECKS}
 397   if (mFreeEntryHead = nil) then raise Exception.Create('internal error in hash entry allocator (0)');
 398   if (mFreeEntryHead.hash <> 0) then raise Exception.Create('internal error in hash entry allocator (1)');
 399   {$ENDIF}
 400   result := mFreeEntryHead;
 401   mFreeEntryHead := result.nextFree;
 402   {$IFDEF RBHASH_SANITY_CHECKS}
 403   Inc(mEntriesUsed);
 404   {$ENDIF}
 405   result.nextFree := nil; // just in case
 406   // fix mFirstEntry and mLastEntry
 407   idx := Integer((PtrUInt(result)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0]));
 408   {$IFDEF RBHASH_SANITY_CHECKS}
 409   if (idx < 0) or (idx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid entry address)');
 410   if (result <> @mEntries[idx]) then raise Exception.Create('internal error in hash entry allocator (wtf?!)');
 411   {$ENDIF}
 412   if (mFirstEntry < 0) or (idx < mFirstEntry) then mFirstEntry := idx;
 413   if (idx > mLastEntry) then mLastEntry := idx;
 414 end;
 415
 416
 417 procedure THashBase.releaseEntry (e: PEntry);
 418 var
 419   cidx, idx: Integer;
 420 begin
 421   {$IFDEF RBHASH_SANITY_CHECKS}
 422   if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator');
 423   if (mEntriesUsed <> mBucketsUsed) then raise Exception.Create('internal error in hash entry allocator (entry/bucket count mismatch)');
 424   if (e = nil) then raise Exception.Create('internal error in hash entry allocator (trying to release nil entry)');
 425   if (e.hash = 0) then raise Exception.Create('internal error in hash entry allocator (trying to release unallocated entry)');
 426   {$ENDIF}
 427   idx := Integer((PtrUInt(e)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0]));
 428   {$IFDEF RBHASH_SANITY_CHECKS}
 429   if (idx < 0) or (idx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid entry address)');
 430   if (e <> @mEntries[idx]) then raise Exception.Create('internal error in hash entry allocator (wtf?!)');
 431   {$ENDIF}
 432   {$IFDEF RBHASH_SANITY_CHECKS}
 433   Dec(mEntriesUsed);
 434   {$ENDIF}
 435   e.hash := 0;
 436   e.nextFree := mFreeEntryHead;
 437   mFreeEntryHead := e; //idx;
 438   // fix mFirstEntry and mLastEntry
 439   {$IFDEF RBHASH_SANITY_CHECKS}
 440   if (mFirstEntry < 0) or (mLastEntry < 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 0)');
 441   {$ENDIF}
 442   if (mFirstEntry = mLastEntry) then
 443   begin
 444     {$IFDEF RBHASH_SANITY_CHECKS}
 445     if (mEntriesUsed <> 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 1)');
 446     {$ENDIF}
 447     mFirstEntry := -1;
 448     mLastEntry := -1;
 449   end
 450   else
 451   begin
 452     {$IFDEF RBHASH_SANITY_CHECKS}
 453     if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 2)');
 454     {$ENDIF}
 455     // fix first entry index
 456     if (idx = mFirstEntry) then
 457     begin
 458       cidx := idx+1;
 459       while (mEntries[cidx].hash = 0) do Inc(cidx);
 460       {$IFDEF RBHASH_SANITY_CHECKS}
 461       if (cidx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 3)');
 462       {$ENDIF}
 463       mFirstEntry := cidx;
 464     end;
 465     // fix last entry index
 466     if (idx = mLastEntry) then
 467     begin
 468       cidx := idx-1;
 469       while (mEntries[cidx].hash = 0) do Dec(cidx);
 470       {$IFDEF RBHASH_SANITY_CHECKS}
 471       if (cidx < 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 3)');
 472       {$ENDIF}
 473       mLastEntry := cidx;
 474     end;
 475   end;
 476 end;
 477
 478
 479 (*
 480 function THashBase.distToStIdx (idx: LongWord): LongWord; inline;
 481 begin
 482   {$IFDEF RBHASH_SANITY_CHECKS}
 483   assert(idx < Length(mBuckets));
 484   assert(mBuckets[idx] <> nil);
 485   {$ENDIF}
 486   result := mBuckets[idx].hash and High(mBuckets);
 487   if (result <= idx) then result := idx-result else result := idx+(Length(mBuckets)-result);
 488 end;
 489 *)
 490
 491
 492 function THashBase.has (constref akey: KeyT): Boolean;
 493 var
 494   khash, idx: LongWord;
 495   dist, pdist: LongWord;
 496   bhigh: LongWord;
 497 begin
 498   result := false;
 499   if (mBucketsUsed = 0) then exit;
 500
 501   bhigh := High(mBuckets);
 502   khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 503   idx := khash and bhigh;
 504   if (mBuckets[idx] = nil) then exit;
 505
 506   for dist := 0 to bhigh do
 507   begin
 508     if (mBuckets[idx] = nil) then break;
 509     //pdist := distToStIdx(idx);
 510     pdist := mBuckets[idx].hash and bhigh;
 511     if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 512     //
 513     if (dist > pdist) then break;
 514     result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 515     if result then break;
 516     idx := (idx+1) and bhigh;
 517   end;
 518 end;
 519
 520
 521 function THashBase.get (constref akey: KeyT; out rval: ValueT): Boolean;
 522 var
 523   khash, idx: LongWord;
 524   dist, pdist: LongWord;
 525   bhigh: LongWord;
 526 begin
 527   result := false;
 528   if (mBucketsUsed = 0) then begin rval := Default(ValueT); exit; end;
 529
 530   bhigh := High(mBuckets);
 531   khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 532   idx := khash and bhigh;
 533   if (mBuckets[idx] = nil) then begin rval := Default(ValueT); exit; end;
 534
 535   for dist := 0 to bhigh do
 536   begin
 537     if (mBuckets[idx] = nil) then break;
 538     //pdist := distToStIdx(idx);
 539     pdist := mBuckets[idx].hash and bhigh;
 540     if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 541     //
 542     if (dist > pdist) then break;
 543     result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 544     if result then
 545     begin
 546       rval := mBuckets[idx].value;
 547       break;
 548     end;
 549     idx := (idx+1) and bhigh;
 550   end;
 551
 552   if not result then rval := Default(ValueT); // just in case
 553 end;
 554
 555
 556 procedure THashBase.putEntryInternal (swpe: PEntry);
 557 var
 558   idx, dist, pcur, pdist: LongWord;
 559   tmpe: PEntry; // current entry to swap (or nothing)
 560   bhigh: LongWord;
 561 begin
 562   bhigh := High(mBuckets);
 563   idx := swpe.hash and bhigh;
 564   {$IFDEF RBHASH_DEBUG_INSERT}writeln('inserting key ', swpe.key, '; value=', swpe.value, '; wantidx=', idx, '; bhigh=', bhigh);{$ENDIF}
 565   pcur := 0;
 566   for dist := 0 to bhigh do
 567   begin
 568     if (mBuckets[idx] = nil) then
 569     begin
 570       // put entry
 571       {$IFDEF RBHASH_DEBUG_INSERT}writeln('  inserted to ', idx);{$ENDIF}
 572       mBuckets[idx] := swpe;
 573       Inc(mBucketsUsed);
 574       break;
 575     end;
 576     //pdist := distToStIdx(idx);
 577     pdist := mBuckets[idx].hash and bhigh;
 578     if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 579     //
 580     if (pcur > pdist) then
 581     begin
 582       // swapping the current bucket with the one to insert
 583       tmpe := mBuckets[idx];
 584       mBuckets[idx] := swpe;
 585       swpe := tmpe;
 586       pcur := pdist;
 587     end;
 588     idx := (idx+1) and bhigh;
 589     Inc(pcur);
 590   end;
 591 end;
 592
 593
 594 function THashBase.put (constref akey: KeyT; constref aval: ValueT): Boolean;
 595 var
 596   khash, idx, dist, pdist: LongWord;
 597   swpe: PEntry = nil; // current entry to swap (or nothing)
 598   bhigh: LongWord;
 599   newsz, eidx: Integer;
 600 begin
 601   result := false;
 602
 603   bhigh := High(mBuckets);
 604   khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 605   idx := khash and bhigh;
 606
 607   // check if we already have this key
 608   if (mBucketsUsed <> 0) and (mBuckets[idx] <> nil) then
 609   begin
 610     for dist := 0 to bhigh do
 611     begin
 612       if (mBuckets[idx] = nil) then break;
 613       //pdist := distToStIdx(idx);
 614       pdist := mBuckets[idx].hash and bhigh;
 615       if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 616       //
 617       if (dist > pdist) then break;
 618       result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 619       if result then
 620       begin
 621         // replace element
 622         //mBuckets[idx].key := akey;
 623         mBuckets[idx].value := aval;
 624         exit;
 625       end;
 626       idx := (idx+1) and bhigh;
 627     end;
 628   end;
 629
 630   // need to resize hash?
 631   if (mBucketsUsed >= (bhigh+1)*LoadFactorPrc div 100) then
 632   begin
 633     newsz := Length(mBuckets);
 634     if (Length(mEntries) <> newsz) then raise Exception.Create('internal error in hash table (resize)');
 635     if (newsz <= 1024*1024*1024) then newsz *= 2 else raise Exception.Create('hash table too big');
 636     {$IFDEF RBHASH_DEBUG_RESIZE}
 637     writeln('resizing hash; used=', mBucketsUsed, '; total=', (bhigh+1), '; maxload=', (bhigh+1)*LoadFactorPrc div 100, '; newsz=', newsz);
 638     {$ENDIF}
 639     SetLength(mBuckets, newsz);
 640     // resize entries array
 641     eidx := Length(mEntries);
 642     SetLength(mEntries, newsz);
 643     while (eidx < Length(mEntries)) do begin mEntries[eidx].hash := 0; Inc(eidx); end;
 644     // mFreeEntryHead will be fixed in `rehash()`
 645     // reinsert entries
 646     rehash();
 647     // as seed was changed, recalc hash
 648     khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 649   end;
 650
 651   // create new entry
 652   swpe := allocEntry();
 653   swpe.key := akey;
 654   swpe.value := aval;
 655   swpe.hash := khash;
 656
 657   putEntryInternal(swpe);
 658 end;
 659
 660
 661 // see http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
 662 function THashBase.del (constref akey: KeyT): Boolean;
 663 var
 664   khash, idx, idxnext, pdist, dist: LongWord;
 665   bhigh: LongWord;
 666 begin
 667   result := false;
 668   if (mBucketsUsed = 0) then exit;
 669
 670   bhigh := High(mBuckets);
 671   khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 672   idx := khash and bhigh;
 673
 674   // find key
 675   if (mBuckets[idx] = nil) then exit; // no key
 676   for dist := 0 to bhigh do
 677   begin
 678     if (mBuckets[idx] = nil) then break;
 679     //pdist := distToStIdx(idxcur);
 680     pdist := mBuckets[idx].hash and bhigh;
 681     if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 682     //
 683     if (dist > pdist) then break;
 684     result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 685     if result then break;
 686     idx := (idx+1) and bhigh;
 687   end;
 688
 689   if not result then
 690   begin
 691     // key not found
 692     {$IFDEF RBHASH_DEBUG_DELETE}
 693     writeln('del: key ', akey, ': not found');
 694     {$ENDIF}
 695     exit;
 696   end;
 697
 698   {$IFDEF RBHASH_DEBUG_DELETE}
 699   writeln('del: key ', akey, ': found at ', idx, '; ek=', mBuckets[idx].key, '; ev=', mBuckets[idx].value);
 700   {$ENDIF}
 701   releaseEntry(mBuckets[idx]);
 702
 703   idxnext := (idx+1) and bhigh;
 704   for dist := 0 to bhigh do
 705   begin
 706     {$IFDEF RBHASH_DEBUG_DELETE}
 707     writeln(' dist=', dist, '; idx=', idx, '; idxnext=', idxnext, '; ce=', (mBuckets[idx] <> nil), '; ne=', (mBuckets[idxnext] <> nil));
 708     {$ENDIF}
 709     if (mBuckets[idxnext] = nil) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln('  idxnext nil');{$ENDIF} mBuckets[idx] := nil; break; end;
 710     //pdist := distToStIdx(idxnext);
 711     pdist := mBuckets[idxnext].hash and bhigh;
 712     if (pdist <= idxnext) then pdist := idxnext-pdist else pdist := idxnext+((bhigh+1)-pdist);
 713     //
 714     if (pdist = 0) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln('  pdist is zero');{$ENDIF} mBuckets[idx] := nil; break; end;
 715     {$IFDEF RBHASH_DEBUG_DELETE}writeln('  pdist=', pdist);{$ENDIF}
 716     mBuckets[idx] := mBuckets[idxnext];
 717     idx := (idx+1) and bhigh;
 718     idxnext := (idxnext+1) and bhigh;
 719   end;
 720
 721   Dec(mBucketsUsed);
 722 end;
 723
 724
 725 procedure THashBase.rehash ();
 726 var
 727   idx: Integer;
 728   lastfree: PEntry;
 729   e: PEntry = nil; // shut up, fpc!
 730   {$IFDEF RBHASH_SANITY_CHECKS}
 731   cnt: Integer = 0;
 732   {$ENDIF}
 733 begin
 734   // change seed, to minimize pathological cases
 735   if (mSeed = 0) then mSeed := $29a;
 736   mSeed := u32Hash(mSeed);
 737   // clear buckets
 738   for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
 739   mBucketsUsed := 0;
 740   // reinsert entries
 741   mFreeEntryHead := nil;
 742   lastfree := nil;
 743   for idx := 0 to High(mEntries) do
 744   begin
 745     e := @mEntries[idx];
 746     if (e.hash <> 0) then
 747     begin
 748       {$IFDEF RBHASH_SANITY_CHECKS}
 749       if (e.nextFree <> nil) then raise Exception.Create('internal error in rehash: inconsistent');
 750       if (cnt = 0) and (idx <> mFirstEntry) then raise Exception.Create('internal error in rehash: inconsistent (1)');
 751       Inc(cnt);
 752       if (cnt = mBucketsUsed) and (idx <> mLastEntry) then raise Exception.Create('internal error in rehash: inconsistent (2)');
 753       {$ENDIF}
 754       e.hash := hashfn(e.key) xor mSeed; if (e.hash = 0) then e.hash := $29a;
 755       putEntryInternal(e);
 756     end
 757     else
 758     begin
 759       if (lastfree <> nil) then lastfree.nextFree := e else mFreeEntryHead := e;
 760       lastfree := e;
 761     end;
 762   end;
 763   if (lastfree <> nil) then e.nextFree := nil;
 764   {$IFDEF RBHASH_SANITY_CHECKS}
 765   if (cnt <> mBucketsUsed) then raise Exception.Create('internal error in hash table resize (invalid first/last range; 0)');
 766   if (cnt <> mEntriesUsed) then raise Exception.Create('internal error in hash table resize (invalid first/last range; 1)');
 767   {$ENDIF}
 768 end;
 769
 770
 771 procedure THashBase.compact ();
 772 var
 773   newsz, didx, f: Integer;
 774   {$IFDEF RBHASH_SANITY_CHECKS}
 775   cnt: Integer;
 776   {$ENDIF}
 777 begin
 778   newsz := nextPOT(LongWord(mBucketsUsed));
 779   if (newsz >= 1024*1024*1024) then exit;
 780   if (newsz*2 >= Length(mBuckets)) then exit;
 781   if (newsz*2 < 128) then exit;
 782   {$IFDEF RBHASH_DEBUG_COMPACT}writeln('compacting; used=', mBucketsUsed, '; oldsizePOT=', newsz, '; newsize=', newsz*2);{$ENDIF}
 783   newsz *= 2;
 784   // move all entries to top
 785   if (mFirstEntry >= 0) then
 786   begin
 787     {$IFDEF RBHASH_SANITY_CHECKS}
 788     if (mBucketsUsed < 1) then raise Exception.Create('internal error in hash table (invalid bucket count; 0)');
 789     {$ENDIF}
 790     didx := 0;
 791     while (didx < Length(mEntries)) do if (mEntries[didx].hash <> 0) then Inc(didx) else break;
 792     f := didx+1;
 793     // copy entries
 794     while true do
 795     begin
 796       if (mEntries[f].hash <> 0) then
 797       begin
 798         {$IFDEF RBHASH_SANITY_CHECKS}
 799         if (didx >= f) then raise Exception.Create('internal error in hash: inconsistent');
 800         {$ENDIF}
 801         mEntries[didx] := mEntries[f];
 802         mEntries[f].hash := 0;
 803         Inc(didx);
 804         if (f = mLastEntry) then break;
 805         while (didx < Length(mEntries)) do if (mEntries[didx].hash <> 0) then Inc(didx) else break;
 806       end;
 807       Inc(f);
 808     end;
 809     {$IFDEF RBHASH_SANITY_CHECKS}
 810     if (didx <> mBucketsUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 1)');
 811     {$ENDIF}
 812     mFirstEntry := 0;
 813     mLastEntry := mBucketsUsed-1;
 814     {$IFDEF RBHASH_SANITY_CHECKS}
 815     cnt := 0;
 816     for f := mFirstEntry to mLastEntry do
 817     begin
 818       if (mEntries[f].hash = 0) then raise Exception.Create('internal error in hash table (invalid first/last range; 2)');
 819       Inc(cnt);
 820     end;
 821     if (cnt <> mBucketsUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 3)');
 822     if (cnt <> mEntriesUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 4)');
 823     for f := mLastEntry+1 to High(mEntries) do
 824     begin
 825       if (mEntries[f].hash <> 0) then raise Exception.Create('internal error in hash table (invalid first/last range; 5)');
 826     end;
 827     {$ENDIF}
 828   end
 829   else
 830   begin
 831     {$IFDEF RBHASH_SANITY_CHECKS}
 832     if (mBucketsUsed <> 0) then raise Exception.Create('internal error in hash table (invalid bucket count; 1)');
 833     {$ENDIF}
 834   end;
 835   // shrink
 836   SetLength(mBuckets, newsz);
 837   SetLength(mEntries, newsz);
 838   // mFreeEntryHead will be fixed in `rehash()`
 839   // reinsert entries
 840   rehash();
 841 end;
 842
 843
 844 function THashBase.forEach (it: TIteratorFn): Boolean;
 845 var
 846   i: Integer;
 847 begin
 848   result := false;
 849   if not assigned(it) then exit;
 850   i := mFirstEntry;
 851   if (i < 0) then exit;
 852   while (i <= mLastEntry) do
 853   begin
 854     if (mEntries[i].hash <> 0) then
 855     begin
 856       result := it(mEntries[i].key, mEntries[i].value);
 857       if result then exit;
 858     end;
 859     Inc(i);
 860   end;
 861 end;
 862
 863
 864 end.