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(D2F_DEBUG)}16{$ELSE}512{$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
  42   private
  43     type
  44       PEntry = ^TEntry;
  45       TEntry = record
  46         key: KeyT;
  47         value: ValueT;
  48         hash: LongWord; // key hash or 0
  49         nextFree: PEntry; // next free entry
  50       end;
  51
  52   private
  53     hashfn: THashFn;
  54     equfn: TEquFn;
  55     mBuckets: array of PEntry; // entries, points to mEntries elements
  56     mBucketsUsed: Integer;
  57     mEntries: array of TEntry;
  58     {$IFDEF RBHASH_SANITY_CHECKS}
  59     mEntriesUsed: Integer;
  60     {$ENDIF}
  61     mFreeEntryHead: PEntry;
  62     mFirstEntry, mLastEntry: Integer;
  63     mSeed: LongWord;
  64
  65   private
  66     function allocEntry (): PEntry;
  67     procedure releaseEntry (e: PEntry);
  68
  69     //function distToStIdx (idx: LongWord): LongWord; inline;
  70
  71     procedure putEntryInternal (swpe: PEntry);
  72
  73     function getCapacity (): Integer; inline;
  74
  75   public
  76     constructor Create (ahashfn: THashFn; aequfn: TEquFn);
  77     destructor Destroy (); override;
  78
  79     procedure clear ();
  80     procedure reset (); // don't shrink buckets
  81
  82     procedure rehash ();
  83     procedure compact (); // call this instead of `rehash()` after alot of deletions
  84
  85     function get (constref akey: KeyT; out rval: ValueT): Boolean; // `true`: found
  86     function put (constref akey: KeyT; constref aval: ValueT): Boolean; // `true`: replaced
  87     function has (constref akey: KeyT): Boolean; // `true`: found
  88     function del (constref akey: KeyT): Boolean; // `true`: deleted
  89
  90     //WARNING! don't modify table in iterator (queries are ok, though)
  91     function forEach (it: TIteratorFn): Boolean;
  92
  93     property count: Integer read mBucketsUsed;
  94     property capacity: Integer read getCapacity;
  95   end;
  96
  97
  98 type
  99   TJoaatHasher = record
 100   private
 101     seed: LongWord; // initial seed value; MUST BE FIRST
 102     hash: LongWord; // current value
 103
 104   public
 105     constructor Create (aseed: LongWord);
 106
 107     procedure reset (); inline; overload;
 108     procedure reset (aseed: LongWord); inline; overload;
 109
 110     procedure put (const buf; len: LongWord);
 111
 112     // current hash value
 113     // you can continue putting data, as this is not destructive
 114     function value: LongWord; inline;
 115   end;
 116
 117
 118 type
 119   THashIntInt = specialize THashBase<Integer, Integer>;
 120
 121 function hashNewIntInt (): THashIntInt;
 122
 123
 124 function u32Hash (a: LongWord): LongWord; inline;
 125 function fnvHash (const buf; len: LongWord): LongWord;
 126 function joaatHash (const buf; len: LongWord): LongWord;
 127
 128 function nextPOT (x: LongWord): LongWord; inline;
 129
 130
 131 implementation
 132
 133 uses
 134   SysUtils;
 135
 136
 137 // ////////////////////////////////////////////////////////////////////////// //
 138 {$PUSH}
 139 {$RANGECHECKS OFF}
 140 function nextPOT (x: LongWord): LongWord; inline;
 141 begin
 142   result := x;
 143   result := result or (result shr 1);
 144   result := result or (result shr 2);
 145   result := result or (result shr 4);
 146   result := result or (result shr 8);
 147   result := result or (result shr 16);
 148   // already pot?
 149   if (x <> 0) and ((x and (x-1)) = 0) then result := result and (not (result shr 1)) else result += 1;
 150 end;
 151 {$POP}
 152
 153
 154 // ////////////////////////////////////////////////////////////////////////// //
 155 function hiiequ (constref a, b: Integer): Boolean; begin result := (a = b); end;
 156
 157 {$PUSH}
 158 {$RANGECHECKS OFF}
 159 function hiihash (constref k: Integer): LongWord;
 160 begin
 161   result := k;
 162   result -= (result shl 6);
 163   result := result xor (result shr 17);
 164   result -= (result shl 9);
 165   result := result xor (result shl 4);
 166   result -= (result shl 3);
 167   result := result xor (result shl 10);
 168   result := result xor (result shr 15);
 169 end;
 170 {$POP}
 171
 172
 173 function hashNewIntInt (): THashIntInt;
 174 begin
 175   result := THashIntInt.Create(hiihash, hiiequ);
 176 end;
 177
 178
 179 // ////////////////////////////////////////////////////////////////////////// //
 180 {$PUSH}
 181 {$RANGECHECKS OFF}
 182 constructor TJoaatHasher.Create (aseed: LongWord);
 183 begin
 184   reset(aseed);
 185 end;
 186
 187
 188 procedure TJoaatHasher.reset (); inline; overload;
 189 begin
 190   hash := seed;
 191 end;
 192
 193
 194 procedure TJoaatHasher.reset (aseed: LongWord); inline; overload;
 195 begin
 196   seed := aseed;
 197   hash := aseed;
 198 end;
 199
 200
 201 procedure TJoaatHasher.put (const buf; len: LongWord);
 202 var
 203   bytes: PByte;
 204   h: LongWord;
 205 begin
 206   if (len < 1) then exit;
 207   bytes := PByte(@buf);
 208   h := hash;
 209   while (len > 0) do
 210   begin
 211     h += bytes^;
 212     h += (h shl 10);
 213     h := h xor (h shr 6);
 214     Dec(len);
 215     Inc(bytes);
 216   end;
 217   hash := h;
 218 end;
 219
 220
 221 function TJoaatHasher.value: LongWord; inline;
 222 begin
 223   result := hash;
 224   result += (result shl 3);
 225   result := result xor (result shr 11);
 226   result += (result shl 15);
 227 end;
 228 {$POP}
 229
 230
 231 function joaatHash (const buf; len: LongWord): LongWord;
 232 var
 233   h: TJoaatHasher;
 234 begin
 235   h := TJoaatHasher.Create(0);
 236   h.put(buf, len);
 237   result := h.value;
 238 end;
 239
 240
 241 // ////////////////////////////////////////////////////////////////////////// //
 242 {$PUSH}
 243 {$RANGECHECKS OFF}
 244 // fnv-1a: http://www.isthe.com/chongo/tech/comp/fnv/
 245 function fnvHash (const buf; len: LongWord): LongWord;
 246 var
 247   b: PByte;
 248 begin
 249   b := @buf;
 250   result := 2166136261; // fnv offset basis
 251   while (len > 0) do
 252   begin
 253     result := result xor b^;
 254     result := result*16777619; // 32-bit fnv prime
 255     Inc(b);
 256     Dec(len);
 257   end;
 258 end;
 259 {$POP}
 260
 261
 262 {$PUSH}
 263 {$RANGECHECKS OFF}
 264 function u32Hash (a: LongWord): LongWord; inline;
 265 begin
 266   result := a;
 267   result -= (result shl 6);
 268   result := result xor (result shr 17);
 269   result -= (result shl 9);
 270   result := result xor (result shl 4);
 271   result -= (result shl 3);
 272   result := result xor (result shl 10);
 273   result := result xor (result shr 15);
 274 end;
 275 {$POP}
 276
 277
 278 // ////////////////////////////////////////////////////////////////////////// //
 279 constructor THashBase.Create (ahashfn: THashFn; aequfn: TEquFn);
 280 begin
 281   if not assigned(ahashfn) then raise Exception.Create('cannot create hash without hash function');
 282   if not assigned(aequfn) then raise Exception.Create('cannot create hash without equality function');
 283
 284   hashfn := ahashfn;
 285   equfn := aequfn;
 286   mSeed := u32Hash($29a);
 287
 288   clear();
 289 end;
 290
 291
 292 destructor THashBase.Destroy ();
 293 begin
 294   mBuckets := nil;
 295   mEntries := nil;
 296   inherited;
 297 end;
 298
 299
 300 procedure THashBase.clear ();
 301 var
 302   idx: Integer;
 303 begin
 304   SetLength(mBuckets, InitSize);
 305   for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
 306
 307   SetLength(mEntries, Length(mBuckets));
 308   for idx := 0 to High(mEntries)-1 do
 309   begin
 310     mEntries[idx].hash := 0;
 311     mEntries[idx].nextFree := @mEntries[idx+1]; //idx+1;
 312   end;
 313   mEntries[High(mEntries)].hash := 0;
 314   mEntries[High(mEntries)].nextFree := nil;
 315
 316   mBucketsUsed := 0;
 317   {$IFDEF RBHASH_SANITY_CHECKS}
 318   mEntriesUsed := 0;
 319   {$ENDIF}
 320   mFreeEntryHead := @mEntries[0];
 321   mFirstEntry := -1;
 322   mLastEntry := -1;
 323 end;
 324
 325
 326 procedure THashBase.reset ();
 327 var
 328   idx: Integer;
 329 begin
 330   if (mBucketsUsed > 0) then
 331   begin
 332     for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
 333     for idx := 0 to High(mEntries)-1 do
 334     begin
 335       mEntries[idx].hash := 0;
 336       mEntries[idx].nextFree := @mEntries[idx+1]; //idx+1;
 337     end;
 338     mEntries[High(mEntries)].hash := 0;
 339     mEntries[High(mEntries)].nextFree := nil;
 340
 341     mBucketsUsed := 0;
 342     {$IFDEF RBHASH_SANITY_CHECKS}
 343     mEntriesUsed := 0;
 344     {$ENDIF}
 345     mFreeEntryHead := @mEntries[0];
 346     mFirstEntry := -1;
 347     mLastEntry := -1;
 348   end;
 349 end;
 350
 351
 352 function THashBase.getCapacity (): Integer; inline; begin result := Length(mBuckets); end;
 353
 354
 355 function THashBase.allocEntry (): PEntry;
 356 var
 357   idx: Integer;
 358 begin
 359   {$IFDEF RBHASH_SANITY_CHECKS}
 360   if (mFreeEntryHead = nil) then raise Exception.Create('internal error in hash entry allocator (0)');
 361   if (mFreeEntryHead.hash <> 0) then raise Exception.Create('internal error in hash entry allocator (1)');
 362   {$ENDIF}
 363   result := mFreeEntryHead;
 364   mFreeEntryHead := result.nextFree;
 365   {$IFDEF RBHASH_SANITY_CHECKS}
 366   Inc(mEntriesUsed);
 367   {$ENDIF}
 368   result.nextFree := nil; // just in case
 369   // fix mFirstEntry and mLastEntry
 370   idx := Integer((PtrUInt(result)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0]));
 371   {$IFDEF RBHASH_SANITY_CHECKS}
 372   if (idx < 0) or (idx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid entry address)');
 373   if (result <> @mEntries[idx]) then raise Exception.Create('internal error in hash entry allocator (wtf?!)');
 374   {$ENDIF}
 375   if (mFirstEntry < 0) or (idx < mFirstEntry) then mFirstEntry := idx;
 376   if (idx > mLastEntry) then mLastEntry := idx;
 377 end;
 378
 379
 380 procedure THashBase.releaseEntry (e: PEntry);
 381 var
 382   cidx, idx: Integer;
 383 begin
 384   {$IFDEF RBHASH_SANITY_CHECKS}
 385   if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator');
 386   if (mEntriesUsed <> mBucketsUsed) then raise Exception.Create('internal error in hash entry allocator (entry/bucket count mismatch)');
 387   if (e = nil) then raise Exception.Create('internal error in hash entry allocator (trying to release nil entry)');
 388   if (e.hash = 0) then raise Exception.Create('internal error in hash entry allocator (trying to release unallocated entry)');
 389   {$ENDIF}
 390   idx := Integer((PtrUInt(e)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0]));
 391   {$IFDEF RBHASH_SANITY_CHECKS}
 392   if (idx < 0) or (idx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid entry address)');
 393   if (e <> @mEntries[idx]) then raise Exception.Create('internal error in hash entry allocator (wtf?!)');
 394   {$ENDIF}
 395   e.hash := 0;
 396   e.nextFree := mFreeEntryHead;
 397   mFreeEntryHead := e; //idx;
 398   {$IFDEF RBHASH_SANITY_CHECKS}
 399   Dec(mEntriesUsed);
 400   {$ENDIF}
 401   // fix mFirstEntry and mLastEntry
 402   {$IFDEF RBHASH_SANITY_CHECKS}
 403   if (mFirstEntry < 0) or (mLastEntry < 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 0)');
 404   {$ENDIF}
 405   if (mFirstEntry = mLastEntry) then
 406   begin
 407     {$IFDEF RBHASH_SANITY_CHECKS}
 408     if (mEntriesUsed <> 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 1)');
 409     {$ENDIF}
 410     mFirstEntry := -1;
 411     mLastEntry := -1;
 412   end
 413   else
 414   begin
 415     {$IFDEF RBHASH_SANITY_CHECKS}
 416     if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 2)');
 417     {$ENDIF}
 418     // fix first entry index
 419     if (idx = mFirstEntry) then
 420     begin
 421       cidx := idx+1;
 422       while (mEntries[cidx].hash = 0) do Inc(cidx);
 423       {$IFDEF RBHASH_SANITY_CHECKS}
 424       if (cidx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 3)');
 425       {$ENDIF}
 426       mFirstEntry := cidx;
 427     end;
 428     // fix last entry index
 429     if (idx = mLastEntry) then
 430     begin
 431       cidx := idx-1;
 432       while (mEntries[cidx].hash = 0) do Dec(cidx);
 433       {$IFDEF RBHASH_SANITY_CHECKS}
 434       if (cidx < 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 3)');
 435       {$ENDIF}
 436       mLastEntry := cidx;
 437     end;
 438   end;
 439 end;
 440
 441
 442 (*
 443 function THashBase.distToStIdx (idx: LongWord): LongWord; inline;
 444 begin
 445   {$IFDEF RBHASH_SANITY_CHECKS}
 446   assert(idx < Length(mBuckets));
 447   assert(mBuckets[idx] <> nil);
 448   {$ENDIF}
 449   result := mBuckets[idx].hash and High(mBuckets);
 450   if (result <= idx) then result := idx-result else result := idx+(Length(mBuckets)-result);
 451 end;
 452 *)
 453
 454
 455 function THashBase.has (constref akey: KeyT): Boolean;
 456 var
 457   khash, idx: LongWord;
 458   dist, pdist: LongWord;
 459   bhigh: LongWord;
 460 begin
 461   result := false;
 462   if (mBucketsUsed = 0) then exit;
 463
 464   bhigh := High(mBuckets);
 465   khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 466   idx := khash and bhigh;
 467   if (mBuckets[idx] = nil) then exit;
 468
 469   for dist := 0 to bhigh do
 470   begin
 471     if (mBuckets[idx] = nil) then break;
 472     //pdist := distToStIdx(idx);
 473     pdist := mBuckets[idx].hash and bhigh;
 474     if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 475     //
 476     if (dist > pdist) then break;
 477     result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 478     if result then break;
 479     idx := (idx+1) and bhigh;
 480   end;
 481 end;
 482
 483
 484 function THashBase.get (constref akey: KeyT; out rval: ValueT): Boolean;
 485 var
 486   khash, idx: LongWord;
 487   dist, pdist: LongWord;
 488   bhigh: LongWord;
 489 begin
 490   result := false;
 491   if (mBucketsUsed = 0) then begin rval := Default(ValueT); exit; end;
 492
 493   bhigh := High(mBuckets);
 494   khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 495   idx := khash and bhigh;
 496   if (mBuckets[idx] = nil) then begin rval := Default(ValueT); exit; end;
 497
 498   for dist := 0 to bhigh do
 499   begin
 500     if (mBuckets[idx] = nil) then break;
 501     //pdist := distToStIdx(idx);
 502     pdist := mBuckets[idx].hash and bhigh;
 503     if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 504     //
 505     if (dist > pdist) then break;
 506     result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 507     if result then
 508     begin
 509       rval := mBuckets[idx].value;
 510       break;
 511     end;
 512     idx := (idx+1) and bhigh;
 513   end;
 514
 515   if not result then rval := Default(ValueT); // just in case
 516 end;
 517
 518
 519 procedure THashBase.putEntryInternal (swpe: PEntry);
 520 var
 521   idx, dist, pcur, pdist: LongWord;
 522   tmpe: PEntry; // current entry to swap (or nothing)
 523   bhigh: LongWord;
 524 begin
 525   bhigh := High(mBuckets);
 526   idx := swpe.hash and bhigh;
 527   {$IFDEF RBHASH_DEBUG_INSERT}writeln('inserting key ', swpe.key, '; value=', swpe.value, '; wantidx=', idx, '; bhigh=', bhigh);{$ENDIF}
 528   pcur := 0;
 529   for dist := 0 to bhigh do
 530   begin
 531     if (mBuckets[idx] = nil) then
 532     begin
 533       // put entry
 534       {$IFDEF RBHASH_DEBUG_INSERT}writeln('  inserted to ', idx);{$ENDIF}
 535       mBuckets[idx] := swpe;
 536       Inc(mBucketsUsed);
 537       break;
 538     end;
 539     //pdist := distToStIdx(idx);
 540     pdist := mBuckets[idx].hash and bhigh;
 541     if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 542     //
 543     if (pcur > pdist) then
 544     begin
 545       // swapping the current bucket with the one to insert
 546       tmpe := mBuckets[idx];
 547       mBuckets[idx] := swpe;
 548       swpe := tmpe;
 549       pcur := pdist;
 550     end;
 551     idx := (idx+1) and bhigh;
 552     Inc(pcur);
 553   end;
 554 end;
 555
 556
 557 function THashBase.put (constref akey: KeyT; constref aval: ValueT): Boolean;
 558 var
 559   khash, idx, dist, pdist: LongWord;
 560   swpe: PEntry = nil; // current entry to swap (or nothing)
 561   bhigh: LongWord;
 562   newsz, eidx: Integer;
 563 begin
 564   result := false;
 565
 566   bhigh := High(mBuckets);
 567   khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 568   idx := khash and bhigh;
 569
 570   // check if we already have this key
 571   if (mBucketsUsed <> 0) and (mBuckets[idx] <> nil) then
 572   begin
 573     for dist := 0 to bhigh do
 574     begin
 575       if (mBuckets[idx] = nil) then break;
 576       //pdist := distToStIdx(idx);
 577       pdist := mBuckets[idx].hash and bhigh;
 578       if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 579       //
 580       if (dist > pdist) then break;
 581       result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 582       if result then
 583       begin
 584         // replace element
 585         //mBuckets[idx].key := akey;
 586         mBuckets[idx].value := aval;
 587         exit;
 588       end;
 589       idx := (idx+1) and bhigh;
 590     end;
 591   end;
 592
 593   // need to resize hash?
 594   if (mBucketsUsed >= (bhigh+1)*LoadFactorPrc div 100) then
 595   begin
 596     newsz := Length(mBuckets);
 597     if (Length(mEntries) <> newsz) then raise Exception.Create('internal error in hash table (resize)');
 598     if (newsz <= 1024*1024*1024) then newsz *= 2 else raise Exception.Create('hash table too big');
 599     {$IFDEF RBHASH_DEBUG_RESIZE}
 600     writeln('resizing hash; used=', mBucketsUsed, '; total=', (bhigh+1), '; maxload=', (bhigh+1)*LoadFactorPrc div 100, '; newsz=', newsz);
 601     {$ENDIF}
 602     SetLength(mBuckets, newsz);
 603     // resize entries array
 604     eidx := Length(mEntries);
 605     SetLength(mEntries, newsz);
 606     while (eidx < Length(mEntries)) do begin mEntries[eidx].hash := 0; Inc(eidx); end;
 607     // mFreeEntryHead will be fixed in `rehash()`
 608     // reinsert entries
 609     rehash();
 610     // as seed was changed, recalc hash
 611     khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 612   end;
 613
 614   // create new entry
 615   swpe := allocEntry();
 616   swpe.key := akey;
 617   swpe.value := aval;
 618   swpe.hash := khash;
 619
 620   putEntryInternal(swpe);
 621 end;
 622
 623
 624 // see http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
 625 function THashBase.del (constref akey: KeyT): Boolean;
 626 var
 627   khash, idx, idxnext, pdist, dist: LongWord;
 628   bhigh: LongWord;
 629 begin
 630   result := false;
 631   if (mBucketsUsed = 0) then exit;
 632
 633   bhigh := High(mBuckets);
 634   khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 635   idx := khash and bhigh;
 636
 637   // find key
 638   if (mBuckets[idx] = nil) then exit; // no key
 639   for dist := 0 to bhigh do
 640   begin
 641     if (mBuckets[idx] = nil) then break;
 642     //pdist := distToStIdx(idxcur);
 643     pdist := mBuckets[idx].hash and bhigh;
 644     if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 645     //
 646     if (dist > pdist) then break;
 647     result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 648     if result then break;
 649     idx := (idx+1) and bhigh;
 650   end;
 651
 652   if not result then
 653   begin
 654     // key not found
 655     {$IFDEF RBHASH_DEBUG_DELETE}
 656     writeln('del: key ', akey, ': not found');
 657     {$ENDIF}
 658     exit;
 659   end;
 660
 661   {$IFDEF RBHASH_DEBUG_DELETE}
 662   writeln('del: key ', akey, ': found at ', idx, '; ek=', mBuckets[idx].key, '; ev=', mBuckets[idx].value);
 663   {$ENDIF}
 664   releaseEntry(mBuckets[idx]);
 665
 666   idxnext := (idx+1) and bhigh;
 667   for dist := 0 to bhigh do
 668   begin
 669     {$IFDEF RBHASH_DEBUG_DELETE}
 670     writeln(' dist=', dist, '; idx=', idx, '; idxnext=', idxnext, '; ce=', (mBuckets[idx] <> nil), '; ne=', (mBuckets[idxnext] <> nil));
 671     {$ENDIF}
 672     if (mBuckets[idxnext] = nil) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln('  idxnext nil');{$ENDIF} mBuckets[idx] := nil; break; end;
 673     //pdist := distToStIdx(idxnext);
 674     pdist := mBuckets[idxnext].hash and bhigh;
 675     if (pdist <= idxnext) then pdist := idxnext-pdist else pdist := idxnext+((bhigh+1)-pdist);
 676     //
 677     if (pdist = 0) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln('  pdist is zero');{$ENDIF} mBuckets[idx] := nil; break; end;
 678     {$IFDEF RBHASH_DEBUG_DELETE}writeln('  pdist=', pdist);{$ENDIF}
 679     mBuckets[idx] := mBuckets[idxnext];
 680     idx := (idx+1) and bhigh;
 681     idxnext := (idxnext+1) and bhigh;
 682   end;
 683
 684   Dec(mBucketsUsed);
 685 end;
 686
 687
 688 procedure THashBase.rehash ();
 689 var
 690   idx: Integer;
 691   lastfree: PEntry;
 692   e: PEntry = nil; // shut up, fpc!
 693   {$IFDEF RBHASH_SANITY_CHECKS}
 694   cnt: Integer = 0;
 695   {$ENDIF}
 696 begin
 697   // change seed, to minimize pathological cases
 698   if (mSeed = 0) then mSeed := $29a;
 699   mSeed := u32Hash(mSeed);
 700   // clear buckets
 701   for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
 702   mBucketsUsed := 0;
 703   // reinsert entries
 704   mFreeEntryHead := nil;
 705   lastfree := nil;
 706   for idx := 0 to High(mEntries) do
 707   begin
 708     e := @mEntries[idx];
 709     if (e.hash <> 0) then
 710     begin
 711       {$IFDEF RBHASH_SANITY_CHECKS}
 712       if (e.nextFree <> nil) then raise Exception.Create('internal error in rehash: inconsistent');
 713       if (cnt = 0) and (idx <> mFirstEntry) then raise Exception.Create('internal error in rehash: inconsistent (1)');
 714       Inc(cnt);
 715       if (cnt = mBucketsUsed) and (idx <> mLastEntry) then raise Exception.Create('internal error in rehash: inconsistent (2)');
 716       {$ENDIF}
 717       e.hash := hashfn(e.key) xor mSeed; if (e.hash = 0) then e.hash := $29a;
 718       putEntryInternal(e);
 719     end
 720     else
 721     begin
 722       if (lastfree <> nil) then lastfree.nextFree := e else mFreeEntryHead := e;
 723       lastfree := e;
 724     end;
 725   end;
 726   if (lastfree <> nil) then e.nextFree := nil;
 727   {$IFDEF RBHASH_SANITY_CHECKS}
 728   if (cnt <> mBucketsUsed) then raise Exception.Create('internal error in hash table resize (invalid first/last range; 0)');
 729   if (cnt <> mEntriesUsed) then raise Exception.Create('internal error in hash table resize (invalid first/last range; 1)');
 730   {$ENDIF}
 731 end;
 732
 733
 734 procedure THashBase.compact ();
 735 var
 736   newsz, didx, f: Integer;
 737   {$IFDEF RBHASH_SANITY_CHECKS}
 738   cnt: Integer;
 739   {$ENDIF}
 740 begin
 741   newsz := nextPOT(LongWord(mBucketsUsed));
 742   if (newsz >= 1024*1024*1024) then exit;
 743   if (newsz*2 >= Length(mBuckets)) then exit;
 744   if (newsz*2 < 128) then exit;
 745   {$IFDEF RBHASH_DEBUG_COMPACT}writeln('compacting; used=', mBucketsUsed, '; oldsizePOT=', newsz, '; newsize=', newsz*2);{$ENDIF}
 746   newsz *= 2;
 747   // move all entries to top
 748   if (mFirstEntry >= 0) then
 749   begin
 750     {$IFDEF RBHASH_SANITY_CHECKS}
 751     if (mBucketsUsed < 1) then raise Exception.Create('internal error in hash table (invalid bucket count; 0)');
 752     {$ENDIF}
 753     didx := 0;
 754     while (didx < Length(mEntries)) do if (mEntries[didx].hash <> 0) then Inc(didx) else break;
 755     f := didx+1;
 756     // copy entries
 757     while true do
 758     begin
 759       if (mEntries[f].hash <> 0) then
 760       begin
 761         {$IFDEF RBHASH_SANITY_CHECKS}
 762         if (didx >= f) then raise Exception.Create('internal error in hash: inconsistent');
 763         {$ENDIF}
 764         mEntries[didx] := mEntries[f];
 765         mEntries[f].hash := 0;
 766         Inc(didx);
 767         if (f = mLastEntry) then break;
 768         while (didx < Length(mEntries)) do if (mEntries[didx].hash <> 0) then Inc(didx) else break;
 769       end;
 770       Inc(f);
 771     end;
 772     {$IFDEF RBHASH_SANITY_CHECKS}
 773     if (didx <> mBucketsUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 1)');
 774     {$ENDIF}
 775     mFirstEntry := 0;
 776     mLastEntry := mBucketsUsed-1;
 777     {$IFDEF RBHASH_SANITY_CHECKS}
 778     cnt := 0;
 779     for f := mFirstEntry to mLastEntry do
 780     begin
 781       if (mEntries[f].hash = 0) then raise Exception.Create('internal error in hash table (invalid first/last range; 2)');
 782       Inc(cnt);
 783     end;
 784     if (cnt <> mBucketsUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 3)');
 785     if (cnt <> mEntriesUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 4)');
 786     for f := mLastEntry+1 to High(mEntries) do
 787     begin
 788       if (mEntries[f].hash <> 0) then raise Exception.Create('internal error in hash table (invalid first/last range; 5)');
 789     end;
 790     {$ENDIF}
 791   end
 792   else
 793   begin
 794     {$IFDEF RBHASH_SANITY_CHECKS}
 795     if (mBucketsUsed <> 0) then raise Exception.Create('internal error in hash table (invalid bucket count; 1)');
 796     {$ENDIF}
 797   end;
 798   // shrink
 799   SetLength(mBuckets, newsz);
 800   SetLength(mEntries, newsz);
 801   // mFreeEntryHead will be fixed in `rehash()`
 802   // reinsert entries
 803   rehash();
 804 end;
 805
 806
 807 function THashBase.forEach (it: TIteratorFn): Boolean;
 808 var
 809   i: Integer;
 810 begin
 811   result := false;
 812   if not assigned(it) then exit;
 813   i := mFirstEntry;
 814   if (i < 0) then exit;
 815   while (i <= mLastEntry) do
 816   begin
 817     if (mEntries[i].hash <> 0) then
 818     begin
 819       result := it(mEntries[i].key, mEntries[i].value);
 820       if result then exit;
 821     end;
 822     Inc(i);
 823   end;
 824 end;
 825
 826
 827 end.