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