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