src/shared/hashtable.pas

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