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