src/shared/hashtable.pas

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