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