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