src/shared/hashtable.pas

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