src/shared/hashtable.pas

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