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