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