src/shared/hashtable.pas

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