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