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