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