DEADSOFTWARE

typo in mapcvt: microseconds -> milliseconds
[d2df-sdl.git] / 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;
27 interface
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
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
42 type
43 PEntry = ^TEntry;
44 TEntry = record
45 public
46 key: KeyT;
47 value: ValueT;
48 private
49 hash: LongWord; // key hash or 0
50 nextFree: PEntry; // next free entry
51 end;
53 private
54 type
55 TEntryArray = array of TEntry;
57 TValEnumerator = record
58 private
59 mEntries: TEntryArray;
60 mFirstEntry, mLastEntry, cur: Integer;
61 public
62 constructor Create (const aents: TEntryArray; afirst, alast: Integer);
63 function MoveNext (): Boolean; inline;
64 function getCurrent (): ValueT; inline;
65 property Current: ValueT read getCurrent;
66 end;
68 TKeyEnumerator = record
69 private
70 mEntries: TEntryArray;
71 mFirstEntry, mLastEntry, cur: Integer;
72 public
73 constructor Create (const aents: TEntryArray; afirst, alast: Integer);
74 function MoveNext (): Boolean; inline;
75 function getCurrent (): KeyT; inline;
76 property Current: KeyT read getCurrent;
77 end;
79 TKeyValEnumerator = 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 (): PEntry; inline;
87 property Current: PEntry read getCurrent;
88 end;
90 private
91 hashfn: THashFn;
92 equfn: TEquFn;
93 mBuckets: array of PEntry; // entries, points to mEntries elements
94 mBucketsUsed: Integer;
95 mEntries: TEntryArray;
96 {$IFDEF RBHASH_SANITY_CHECKS}
97 mEntriesUsed: Integer;
98 {$ENDIF}
99 mFreeEntryHead: PEntry;
100 mFirstEntry, mLastEntry: Integer;
101 mSeed: LongWord;
103 private
104 function allocEntry (): PEntry;
105 procedure releaseEntry (e: PEntry);
107 //function distToStIdx (idx: LongWord): LongWord; inline;
109 procedure putEntryInternal (swpe: PEntry);
111 function getCapacity (): Integer; inline;
113 public
114 constructor Create (ahashfn: THashFn; aequfn: TEquFn);
115 destructor Destroy (); override;
117 procedure clear ();
118 procedure reset (); // don't shrink buckets
120 procedure rehash ();
121 procedure compact (); // call this instead of `rehash()` after alot of deletions
123 function get (constref akey: KeyT; out rval: ValueT): Boolean; // `true`: found
124 function put (constref akey: KeyT; constref aval: ValueT): Boolean; // `true`: replaced
125 function has (constref akey: KeyT): Boolean; // `true`: found
126 function del (constref akey: KeyT): Boolean; // `true`: deleted
128 //WARNING! don't modify table in iterator (queries are ok, though)
129 function forEach (it: TIteratorFn): Boolean;
131 // default `for ... in` enums values
132 function GetEnumerator (): TValEnumerator;
133 function byKey (): TKeyEnumerator;
134 function byValue (): TValEnumerator;
135 function byKeyValue (): TKeyValEnumerator; // PEntry
137 property count: Integer read mBucketsUsed;
138 property capacity: Integer read getCapacity;
139 end;
141 type
142 TJoaatHasher = record
143 private
144 seed: LongWord; // initial seed value; MUST BE FIRST
145 hash: LongWord; // current value
147 public
148 constructor Create (aseed: LongWord);
150 procedure reset (); inline; overload;
151 procedure reset (aseed: LongWord); inline; overload;
153 procedure put (constref buf; len: LongWord);
155 // current hash value
156 // you can continue putting data, as this is not destructive
157 function value: LongWord; inline;
158 end;
161 type
162 THashIntInt = specialize THashBase<Integer, Integer>;
163 THashStrInt = specialize THashBase<AnsiString, Integer>;
165 function hashNewIntInt (): THashIntInt;
166 function hashNewStrInt (): THashStrInt;
169 function u32Hash (a: LongWord): LongWord; inline;
170 function fnvHash (constref buf; len: LongWord): LongWord;
171 function joaatHash (constref buf; len: LongWord): LongWord;
173 function nextPOT (x: LongWord): LongWord; inline;
176 implementation
178 uses
179 SysUtils;
182 // ////////////////////////////////////////////////////////////////////////// //
183 {$PUSH}
184 {$RANGECHECKS OFF}
185 function nextPOT (x: LongWord): LongWord; inline;
186 begin
187 result := x;
188 result := result or (result shr 1);
189 result := result or (result shr 2);
190 result := result or (result shr 4);
191 result := result or (result shr 8);
192 result := result or (result shr 16);
193 // already pot?
194 if (x <> 0) and ((x and (x-1)) = 0) then result := result and (not (result shr 1)) else result += 1;
195 end;
196 {$POP}
199 // ////////////////////////////////////////////////////////////////////////// //
200 function hiiequ (constref a, b: Integer): Boolean; begin result := (a = b); end;
201 function hsiequ (constref a, b: AnsiString): Boolean; begin result := (a = b); end;
203 {$PUSH}
204 {$RANGECHECKS OFF}
205 function hiihash (constref k: Integer): LongWord;
206 begin
207 result := k;
208 result -= (result shl 6);
209 result := result xor (result shr 17);
210 result -= (result shl 9);
211 result := result xor (result shl 4);
212 result -= (result shl 3);
213 result := result xor (result shl 10);
214 result := result xor (result shr 15);
215 end;
217 function hsihash (constref k: AnsiString): LongWord;
218 begin
219 if (Length(k) > 0) then result := fnvHash(PAnsiChar(k)^, Length(k)) else result := 0;
220 end;
221 {$POP}
224 function hashNewIntInt (): THashIntInt;
225 begin
226 result := THashIntInt.Create(hiihash, hiiequ);
227 end;
230 function hashNewStrInt (): THashStrInt;
231 begin
232 result := THashStrInt.Create(hsihash, hsiequ);
233 end;
236 // ////////////////////////////////////////////////////////////////////////// //
237 {$PUSH}
238 {$RANGECHECKS OFF}
239 constructor TJoaatHasher.Create (aseed: LongWord);
240 begin
241 reset(aseed);
242 end;
245 procedure TJoaatHasher.reset (); inline; overload;
246 begin
247 hash := seed;
248 end;
251 procedure TJoaatHasher.reset (aseed: LongWord); inline; overload;
252 begin
253 seed := aseed;
254 hash := aseed;
255 end;
258 procedure TJoaatHasher.put (constref buf; len: LongWord);
259 var
260 bytes: PByte;
261 h: LongWord;
262 begin
263 if (len < 1) then exit;
264 bytes := PByte(@buf);
265 h := hash;
266 while (len > 0) do
267 begin
268 h += bytes^;
269 h += (h shl 10);
270 h := h xor (h shr 6);
271 Dec(len);
272 Inc(bytes);
273 end;
274 hash := h;
275 end;
278 function TJoaatHasher.value: LongWord; inline;
279 begin
280 result := hash;
281 result += (result shl 3);
282 result := result xor (result shr 11);
283 result += (result shl 15);
284 end;
285 {$POP}
288 function joaatHash (constref buf; len: LongWord): LongWord;
289 var
290 h: TJoaatHasher;
291 begin
292 h := TJoaatHasher.Create(0);
293 h.put(PByte(@buf)^, len);
294 result := h.value;
295 end;
298 // ////////////////////////////////////////////////////////////////////////// //
299 {$PUSH}
300 {$RANGECHECKS OFF}
301 // fnv-1a: http://www.isthe.com/chongo/tech/comp/fnv/
302 function fnvHash (constref buf; len: LongWord): LongWord;
303 var
304 b: PByte;
305 begin
306 b := @buf;
307 result := 2166136261; // fnv offset basis
308 while (len > 0) do
309 begin
310 result := result xor b^;
311 result := result*16777619; // 32-bit fnv prime
312 Inc(b);
313 Dec(len);
314 end;
315 end;
316 {$POP}
319 {$PUSH}
320 {$RANGECHECKS OFF}
321 function u32Hash (a: LongWord): LongWord; inline;
322 begin
323 result := a;
324 result -= (result shl 6);
325 result := result xor (result shr 17);
326 result -= (result shl 9);
327 result := result xor (result shl 4);
328 result -= (result shl 3);
329 result := result xor (result shl 10);
330 result := result xor (result shr 15);
331 end;
332 {$POP}
335 // ////////////////////////////////////////////////////////////////////////// //
336 constructor THashBase.Create (ahashfn: THashFn; aequfn: TEquFn);
337 begin
338 if not assigned(ahashfn) then raise Exception.Create('cannot create hash without hash function');
339 if not assigned(aequfn) then raise Exception.Create('cannot create hash without equality function');
341 hashfn := ahashfn;
342 equfn := aequfn;
343 mSeed := u32Hash($29a);
345 clear();
346 end;
349 destructor THashBase.Destroy ();
350 begin
351 mBuckets := nil;
352 mEntries := nil;
353 inherited;
354 end;
357 procedure THashBase.clear ();
358 var
359 idx: Integer;
360 begin
361 SetLength(mBuckets, InitSize);
362 for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
364 SetLength(mEntries, Length(mBuckets));
366 for idx := 0 to High(mEntries)-1 do
367 begin
368 mEntries[idx].hash := 0;
369 mEntries[idx].nextFree := @mEntries[idx+1]; //idx+1;
370 end;
371 mEntries[High(mEntries)].hash := 0;
372 mEntries[High(mEntries)].nextFree := nil;
375 for idx := 0 to High(mEntries) do
376 begin
377 mEntries[idx].hash := 0;
378 mEntries[idx].nextFree := nil;
379 end;
382 mBucketsUsed := 0;
383 {$IFDEF RBHASH_SANITY_CHECKS}
384 mEntriesUsed := 0;
385 {$ENDIF}
386 mFreeEntryHead := nil; //@mEntries[0];
387 mFirstEntry := -1;
388 mLastEntry := -1;
389 end;
392 procedure THashBase.reset ();
393 var
394 idx: Integer;
395 begin
396 if (mBucketsUsed > 0) then
397 begin
398 for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
400 for idx := 0 to High(mEntries)-1 do
401 begin
402 mEntries[idx].hash := 0;
403 mEntries[idx].nextFree := @mEntries[idx+1]; //idx+1;
404 end;
405 mEntries[High(mEntries)].hash := 0;
406 mEntries[High(mEntries)].nextFree := nil;
409 if (mFirstEntry >= 0) then
410 begin
411 for idx := mFirstEntry to mLastEntry do
412 begin
413 mEntries[idx].hash := 0;
414 mEntries[idx].nextFree := nil;
415 end;
416 end;
419 mBucketsUsed := 0;
420 {$IFDEF RBHASH_SANITY_CHECKS}
421 mEntriesUsed := 0;
422 {$ENDIF}
423 mFreeEntryHead := nil; //@mEntries[0];
424 mFirstEntry := -1;
425 mLastEntry := -1;
426 end;
427 end;
430 function THashBase.getCapacity (): Integer; inline; begin result := Length(mBuckets); end;
433 function THashBase.allocEntry (): PEntry;
434 var
435 idx: Integer;
436 begin
437 if (mFreeEntryHead = nil) then
438 begin
439 if (mLastEntry = High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (0.0)');
440 Inc(mLastEntry);
441 if (mFirstEntry = -1) then
442 begin
443 if (mLastEntry <> 0) then raise Exception.Create('internal error in hash entry allocator (0.1)');
444 mFirstEntry := 0;
445 end;
446 result := @mEntries[mLastEntry];
447 result.nextFree := nil; // just in case
448 {$IFDEF RBHASH_SANITY_CHECKS}
449 Inc(mEntriesUsed);
450 {$ENDIF}
451 exit;
452 end;
453 {$IFDEF RBHASH_SANITY_CHECKS}
454 if (mFreeEntryHead = nil) then raise Exception.Create('internal error in hash entry allocator (0)');
455 if (mFreeEntryHead.hash <> 0) then raise Exception.Create('internal error in hash entry allocator (1)');
456 {$ENDIF}
457 result := mFreeEntryHead;
458 mFreeEntryHead := result.nextFree;
459 {$IFDEF RBHASH_SANITY_CHECKS}
460 Inc(mEntriesUsed);
461 {$ENDIF}
462 result.nextFree := nil; // just in case
463 // fix mFirstEntry and mLastEntry
464 idx := Integer((PtrUInt(result)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0]));
465 {$IFDEF RBHASH_SANITY_CHECKS}
466 if (idx < 0) or (idx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid entry address)');
467 if (result <> @mEntries[idx]) then raise Exception.Create('internal error in hash entry allocator (wtf?!)');
468 {$ENDIF}
469 if (mFirstEntry < 0) or (idx < mFirstEntry) then mFirstEntry := idx;
470 if (idx > mLastEntry) then mLastEntry := idx;
471 end;
474 procedure THashBase.releaseEntry (e: PEntry);
475 var
476 cidx, idx: Integer;
477 begin
478 {$IFDEF RBHASH_SANITY_CHECKS}
479 if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator');
480 if (mEntriesUsed <> mBucketsUsed) then raise Exception.Create('internal error in hash entry allocator (entry/bucket count mismatch)');
481 if (e = nil) then raise Exception.Create('internal error in hash entry allocator (trying to release nil entry)');
482 if (e.hash = 0) then raise Exception.Create('internal error in hash entry allocator (trying to release unallocated entry)');
483 {$ENDIF}
484 idx := Integer((PtrUInt(e)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0]));
485 {$IFDEF RBHASH_SANITY_CHECKS}
486 if (idx < 0) or (idx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid entry address)');
487 if (e <> @mEntries[idx]) then raise Exception.Create('internal error in hash entry allocator (wtf?!)');
488 {$ENDIF}
489 {$IFDEF RBHASH_SANITY_CHECKS}
490 Dec(mEntriesUsed);
491 {$ENDIF}
492 e.hash := 0;
493 e.nextFree := mFreeEntryHead;
494 mFreeEntryHead := e; //idx;
495 // fix mFirstEntry and mLastEntry
496 {$IFDEF RBHASH_SANITY_CHECKS}
497 if (mFirstEntry < 0) or (mLastEntry < 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 0)');
498 {$ENDIF}
499 if (mFirstEntry = mLastEntry) then
500 begin
501 {$IFDEF RBHASH_SANITY_CHECKS}
502 if (mEntriesUsed <> 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 1)');
503 {$ENDIF}
504 mFirstEntry := -1;
505 mLastEntry := -1;
506 end
507 else
508 begin
509 {$IFDEF RBHASH_SANITY_CHECKS}
510 if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 2)');
511 {$ENDIF}
512 // fix first entry index
513 if (idx = mFirstEntry) then
514 begin
515 cidx := idx+1;
516 while (mEntries[cidx].hash = 0) do Inc(cidx);
517 {$IFDEF RBHASH_SANITY_CHECKS}
518 if (cidx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 3)');
519 {$ENDIF}
520 mFirstEntry := cidx;
521 end;
522 // fix last entry index
523 if (idx = mLastEntry) then
524 begin
525 cidx := idx-1;
526 while (mEntries[cidx].hash = 0) do Dec(cidx);
527 {$IFDEF RBHASH_SANITY_CHECKS}
528 if (cidx < 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 3)');
529 {$ENDIF}
530 mLastEntry := cidx;
531 end;
532 end;
533 end;
536 (*
537 function THashBase.distToStIdx (idx: LongWord): LongWord; inline;
538 begin
539 {$IFDEF RBHASH_SANITY_CHECKS}
540 assert(idx < Length(mBuckets));
541 assert(mBuckets[idx] <> nil);
542 {$ENDIF}
543 result := mBuckets[idx].hash and High(mBuckets);
544 if (result <= idx) then result := idx-result else result := idx+(Length(mBuckets)-result);
545 end;
546 *)
549 function THashBase.has (constref akey: KeyT): Boolean;
550 var
551 khash, idx: LongWord;
552 dist, pdist: LongWord;
553 bhigh: LongWord;
554 begin
555 result := false;
556 if (mBucketsUsed = 0) then exit;
558 bhigh := High(mBuckets);
559 khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
560 idx := khash and bhigh;
561 if (mBuckets[idx] = nil) then exit;
563 for dist := 0 to bhigh do
564 begin
565 if (mBuckets[idx] = nil) then break;
566 //pdist := distToStIdx(idx);
567 pdist := mBuckets[idx].hash and bhigh;
568 if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
569 //
570 if (dist > pdist) then break;
571 result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
572 if result then break;
573 idx := (idx+1) and bhigh;
574 end;
575 end;
578 function THashBase.get (constref akey: KeyT; out rval: ValueT): Boolean;
579 var
580 khash, idx: LongWord;
581 dist, pdist: LongWord;
582 bhigh: LongWord;
583 begin
584 result := false;
585 if (mBucketsUsed = 0) then begin rval := Default(ValueT); exit; end;
587 bhigh := High(mBuckets);
588 khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
589 idx := khash and bhigh;
590 if (mBuckets[idx] = nil) then begin rval := Default(ValueT); exit; end;
592 for dist := 0 to bhigh do
593 begin
594 if (mBuckets[idx] = nil) then break;
595 //pdist := distToStIdx(idx);
596 pdist := mBuckets[idx].hash and bhigh;
597 if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
598 //
599 if (dist > pdist) then break;
600 result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
601 if result then
602 begin
603 rval := mBuckets[idx].value;
604 break;
605 end;
606 idx := (idx+1) and bhigh;
607 end;
609 if not result then rval := Default(ValueT); // just in case
610 end;
613 procedure THashBase.putEntryInternal (swpe: PEntry);
614 var
615 idx, dist, pcur, pdist: LongWord;
616 tmpe: PEntry; // current entry to swap (or nothing)
617 bhigh: LongWord;
618 begin
619 bhigh := High(mBuckets);
620 idx := swpe.hash and bhigh;
621 {$IFDEF RBHASH_DEBUG_INSERT}writeln('inserting key ', swpe.key, '; value=', swpe.value, '; wantidx=', idx, '; bhigh=', bhigh);{$ENDIF}
622 pcur := 0;
623 for dist := 0 to bhigh do
624 begin
625 if (mBuckets[idx] = nil) then
626 begin
627 // put entry
628 {$IFDEF RBHASH_DEBUG_INSERT}writeln(' inserted to ', idx);{$ENDIF}
629 mBuckets[idx] := swpe;
630 Inc(mBucketsUsed);
631 break;
632 end;
633 //pdist := distToStIdx(idx);
634 pdist := mBuckets[idx].hash and bhigh;
635 if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
636 //
637 if (pcur > pdist) then
638 begin
639 // swapping the current bucket with the one to insert
640 tmpe := mBuckets[idx];
641 mBuckets[idx] := swpe;
642 swpe := tmpe;
643 pcur := pdist;
644 end;
645 idx := (idx+1) and bhigh;
646 Inc(pcur);
647 end;
648 end;
651 function THashBase.put (constref akey: KeyT; constref aval: ValueT): Boolean;
652 var
653 khash, idx, dist, pdist: LongWord;
654 swpe: PEntry = nil; // current entry to swap (or nothing)
655 bhigh: LongWord;
656 newsz, eidx: Integer;
657 begin
658 result := false;
660 bhigh := High(mBuckets);
661 khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
662 idx := khash and bhigh;
664 // check if we already have this key
665 if (mBucketsUsed <> 0) and (mBuckets[idx] <> nil) then
666 begin
667 for dist := 0 to bhigh do
668 begin
669 if (mBuckets[idx] = nil) then break;
670 //pdist := distToStIdx(idx);
671 pdist := mBuckets[idx].hash and bhigh;
672 if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
673 //
674 if (dist > pdist) then break;
675 result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
676 if result then
677 begin
678 // replace element
679 //mBuckets[idx].key := akey;
680 mBuckets[idx].value := aval;
681 exit;
682 end;
683 idx := (idx+1) and bhigh;
684 end;
685 end;
687 // need to resize hash?
688 if (mBucketsUsed >= (bhigh+1)*LoadFactorPrc div 100) then
689 begin
690 newsz := Length(mBuckets);
691 if (Length(mEntries) <> newsz) then raise Exception.Create('internal error in hash table (resize)');
692 if (newsz <= 1024*1024*1024) then newsz *= 2 else raise Exception.Create('hash table too big');
693 {$IFDEF RBHASH_DEBUG_RESIZE}
694 writeln('resizing hash; used=', mBucketsUsed, '; total=', (bhigh+1), '; maxload=', (bhigh+1)*LoadFactorPrc div 100, '; newsz=', newsz);
695 {$ENDIF}
696 SetLength(mBuckets, newsz);
697 // resize entries array
698 eidx := Length(mEntries);
699 SetLength(mEntries, newsz);
700 while (eidx < Length(mEntries)) do begin mEntries[eidx].hash := 0; Inc(eidx); end;
701 // mFreeEntryHead will be fixed in `rehash()`
702 // reinsert entries
703 rehash();
704 // as seed was changed, recalc hash
705 khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
706 end;
708 // create new entry
709 swpe := allocEntry();
710 swpe.key := akey;
711 swpe.value := aval;
712 swpe.hash := khash;
714 putEntryInternal(swpe);
715 end;
718 // see http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
719 function THashBase.del (constref akey: KeyT): Boolean;
720 var
721 khash, idx, idxnext, pdist, dist: LongWord;
722 bhigh: LongWord;
723 begin
724 result := false;
725 if (mBucketsUsed = 0) then exit;
727 bhigh := High(mBuckets);
728 khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
729 idx := khash and bhigh;
731 // find key
732 if (mBuckets[idx] = nil) then exit; // no key
733 for dist := 0 to bhigh do
734 begin
735 if (mBuckets[idx] = nil) then break;
736 //pdist := distToStIdx(idxcur);
737 pdist := mBuckets[idx].hash and bhigh;
738 if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
739 //
740 if (dist > pdist) then break;
741 result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
742 if result then break;
743 idx := (idx+1) and bhigh;
744 end;
746 if not result then
747 begin
748 // key not found
749 {$IFDEF RBHASH_DEBUG_DELETE}
750 writeln('del: key ', akey, ': not found');
751 {$ENDIF}
752 exit;
753 end;
755 {$IFDEF RBHASH_DEBUG_DELETE}
756 writeln('del: key ', akey, ': found at ', idx, '; ek=', mBuckets[idx].key, '; ev=', mBuckets[idx].value);
757 {$ENDIF}
758 releaseEntry(mBuckets[idx]);
760 idxnext := (idx+1) and bhigh;
761 for dist := 0 to bhigh do
762 begin
763 {$IFDEF RBHASH_DEBUG_DELETE}
764 writeln(' dist=', dist, '; idx=', idx, '; idxnext=', idxnext, '; ce=', (mBuckets[idx] <> nil), '; ne=', (mBuckets[idxnext] <> nil));
765 {$ENDIF}
766 if (mBuckets[idxnext] = nil) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln(' idxnext nil');{$ENDIF} mBuckets[idx] := nil; break; end;
767 //pdist := distToStIdx(idxnext);
768 pdist := mBuckets[idxnext].hash and bhigh;
769 if (pdist <= idxnext) then pdist := idxnext-pdist else pdist := idxnext+((bhigh+1)-pdist);
770 //
771 if (pdist = 0) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln(' pdist is zero');{$ENDIF} mBuckets[idx] := nil; break; end;
772 {$IFDEF RBHASH_DEBUG_DELETE}writeln(' pdist=', pdist);{$ENDIF}
773 mBuckets[idx] := mBuckets[idxnext];
774 idx := (idx+1) and bhigh;
775 idxnext := (idxnext+1) and bhigh;
776 end;
778 Dec(mBucketsUsed);
779 end;
782 procedure THashBase.rehash ();
783 var
784 idx: Integer;
785 lastfree: PEntry;
786 e: PEntry = nil; // shut up, fpc!
787 {$IFDEF RBHASH_SANITY_CHECKS}
788 cnt: Integer = 0;
789 {$ENDIF}
790 begin
791 // change seed, to minimize pathological cases
792 if (mSeed = 0) then mSeed := $29a;
793 mSeed := u32Hash(mSeed);
794 // clear buckets
795 for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
796 mBucketsUsed := 0;
797 // reinsert entries
798 mFreeEntryHead := nil;
799 lastfree := nil;
800 for idx := 0 to High(mEntries) do
801 begin
802 e := @mEntries[idx];
803 if (e.hash <> 0) then
804 begin
805 {$IFDEF RBHASH_SANITY_CHECKS}
806 if (e.nextFree <> nil) then raise Exception.Create('internal error in rehash: inconsistent');
807 if (cnt = 0) and (idx <> mFirstEntry) then raise Exception.Create('internal error in rehash: inconsistent (1)');
808 Inc(cnt);
809 if (cnt = mBucketsUsed) and (idx <> mLastEntry) then raise Exception.Create('internal error in rehash: inconsistent (2)');
810 {$ENDIF}
811 e.hash := hashfn(e.key) xor mSeed; if (e.hash = 0) then e.hash := $29a;
812 putEntryInternal(e);
813 end
814 else
815 begin
816 if (lastfree <> nil) then lastfree.nextFree := e else mFreeEntryHead := e;
817 lastfree := e;
818 end;
819 end;
820 if (lastfree <> nil) then e.nextFree := nil;
821 {$IFDEF RBHASH_SANITY_CHECKS}
822 if (cnt <> mBucketsUsed) then raise Exception.Create('internal error in hash table resize (invalid first/last range; 0)');
823 if (cnt <> mEntriesUsed) then raise Exception.Create('internal error in hash table resize (invalid first/last range; 1)');
824 {$ENDIF}
825 end;
828 procedure THashBase.compact ();
829 var
830 newsz, didx, f: Integer;
831 {$IFDEF RBHASH_SANITY_CHECKS}
832 cnt: Integer;
833 {$ENDIF}
834 begin
835 newsz := nextPOT(LongWord(mBucketsUsed));
836 if (newsz >= 1024*1024*1024) then exit;
837 if (newsz*2 >= Length(mBuckets)) then exit;
838 if (newsz*2 < 128) then exit;
839 {$IFDEF RBHASH_DEBUG_COMPACT}writeln('compacting; used=', mBucketsUsed, '; oldsizePOT=', newsz, '; newsize=', newsz*2);{$ENDIF}
840 newsz *= 2;
841 // move all entries to top
842 if (mFirstEntry >= 0) then
843 begin
844 {$IFDEF RBHASH_SANITY_CHECKS}
845 if (mBucketsUsed < 1) then raise Exception.Create('internal error in hash table (invalid bucket count; 0)');
846 {$ENDIF}
847 didx := 0;
848 while (didx < Length(mEntries)) do if (mEntries[didx].hash <> 0) then Inc(didx) else break;
849 f := didx+1;
850 // copy entries
851 while true do
852 begin
853 if (mEntries[f].hash <> 0) then
854 begin
855 {$IFDEF RBHASH_SANITY_CHECKS}
856 if (didx >= f) then raise Exception.Create('internal error in hash: inconsistent');
857 {$ENDIF}
858 mEntries[didx] := mEntries[f];
859 mEntries[f].hash := 0;
860 Inc(didx);
861 if (f = mLastEntry) then break;
862 while (didx < Length(mEntries)) do if (mEntries[didx].hash <> 0) then Inc(didx) else break;
863 end;
864 Inc(f);
865 end;
866 {$IFDEF RBHASH_SANITY_CHECKS}
867 if (didx <> mBucketsUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 1)');
868 {$ENDIF}
869 mFirstEntry := 0;
870 mLastEntry := mBucketsUsed-1;
871 {$IFDEF RBHASH_SANITY_CHECKS}
872 cnt := 0;
873 for f := mFirstEntry to mLastEntry do
874 begin
875 if (mEntries[f].hash = 0) then raise Exception.Create('internal error in hash table (invalid first/last range; 2)');
876 Inc(cnt);
877 end;
878 if (cnt <> mBucketsUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 3)');
879 if (cnt <> mEntriesUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 4)');
880 for f := mLastEntry+1 to High(mEntries) do
881 begin
882 if (mEntries[f].hash <> 0) then raise Exception.Create('internal error in hash table (invalid first/last range; 5)');
883 end;
884 {$ENDIF}
885 end
886 else
887 begin
888 {$IFDEF RBHASH_SANITY_CHECKS}
889 if (mBucketsUsed <> 0) then raise Exception.Create('internal error in hash table (invalid bucket count; 1)');
890 {$ENDIF}
891 end;
892 // shrink
893 SetLength(mBuckets, newsz);
894 SetLength(mEntries, newsz);
895 // mFreeEntryHead will be fixed in `rehash()`
896 // reinsert entries
897 rehash();
898 end;
901 function THashBase.forEach (it: TIteratorFn): Boolean;
902 var
903 i: Integer;
904 begin
905 result := false;
906 if not assigned(it) then exit;
907 i := mFirstEntry;
908 if (i < 0) then exit;
909 while (i <= mLastEntry) do
910 begin
911 if (mEntries[i].hash <> 0) then
912 begin
913 result := it(mEntries[i].key, mEntries[i].value);
914 if result then exit;
915 end;
916 Inc(i);
917 end;
918 end;
921 // enumerators
922 function THashBase.GetEnumerator (): TValEnumerator;
923 begin
924 if (Length(mEntries) > 0) then result := TValEnumerator.Create(mEntries, mFirstEntry, mLastEntry)
925 else result := TValEnumerator.Create(nil, -1, -1);
926 end;
928 function THashBase.byKey (): TKeyEnumerator;
929 begin
930 if (Length(mEntries) > 0) then result := TKeyEnumerator.Create(mEntries, mFirstEntry, mLastEntry)
931 else result := TKeyEnumerator.Create(nil, -1, -1);
932 end;
934 function THashBase.byValue (): TValEnumerator;
935 begin
936 if (Length(mEntries) > 0) then result := TValEnumerator.Create(mEntries, mFirstEntry, mLastEntry)
937 else result := TValEnumerator.Create(nil, -1, -1);
938 end;
940 function THashBase.byKeyValue (): TKeyValEnumerator; // PEntry
941 begin
942 if (Length(mEntries) > 0) then result := TKeyValEnumerator.Create(mEntries, mFirstEntry, mLastEntry)
943 else result := TKeyValEnumerator.Create(nil, -1, -1);
944 end;
947 // ////////////////////////////////////////////////////////////////////////// //
948 constructor THashBase.TValEnumerator.Create (const aents: TEntryArray; afirst, alast: Integer);
949 begin
950 mEntries := aents;
951 mFirstEntry := afirst;
952 mLastEntry := alast;
953 cur := mFirstEntry-1;
954 end;
956 function THashBase.TValEnumerator.MoveNext (): Boolean; inline;
957 begin
958 Inc(cur);
959 while (cur <= mLastEntry) do
960 begin
961 if (mEntries[cur].hash <> 0) then begin result := true; exit; end;
962 end;
963 result := false;
964 end;
966 function THashBase.TValEnumerator.getCurrent (): ValueT; inline;
967 begin
968 result := mEntries[cur].value;
969 end;
972 // ////////////////////////////////////////////////////////////////////////// //
973 constructor THashBase.TKeyEnumerator.Create (const aents: TEntryArray; afirst, alast: Integer);
974 begin
975 mEntries := aents;
976 mFirstEntry := afirst;
977 mLastEntry := alast;
978 cur := mFirstEntry-1;
979 end;
981 function THashBase.TKeyEnumerator.MoveNext (): Boolean; inline;
982 begin
983 Inc(cur);
984 while (cur <= mLastEntry) do
985 begin
986 if (mEntries[cur].hash <> 0) then begin result := true; exit; end;
987 end;
988 result := false;
989 end;
991 function THashBase.TKeyEnumerator.getCurrent (): KeyT; inline;
992 begin
993 result := mEntries[cur].key;
994 end;
997 // ////////////////////////////////////////////////////////////////////////// //
998 constructor THashBase.TKeyValEnumerator.Create (const aents: TEntryArray; afirst, alast: Integer);
999 begin
1000 mEntries := aents;
1001 mFirstEntry := afirst;
1002 mLastEntry := alast;
1003 cur := mFirstEntry-1;
1004 end;
1006 function THashBase.TKeyValEnumerator.MoveNext (): Boolean; inline;
1007 begin
1008 Inc(cur);
1009 while (cur <= mLastEntry) do
1010 begin
1011 if (mEntries[cur].hash <> 0) then begin result := true; exit; end;
1012 end;
1013 result := false;
1014 end;
1016 function THashBase.TKeyValEnumerator.getCurrent (): PEntry; inline;
1017 begin
1018 result := @mEntries[cur];
1019 end;
1022 end.