X-Git-Url: http://deadsoftware.ru/gitweb?a=blobdiff_plain;f=src%2Fshared%2Fhashtable.pas;h=cb6d35c0f8c684b58320c369907b9a3141e1d664;hb=c7827dd408b445f025117f2c5df2a3c0f4622298;hp=85133c3efbc10d47581f03f132ed6bda137d36b7;hpb=f924968c450e1dc566b3abdde8d2aeac4de11fd0;p=d2df-sdl.git diff --git a/src/shared/hashtable.pas b/src/shared/hashtable.pas index 85133c3..cb6d35c 100644 --- a/src/shared/hashtable.pas +++ b/src/shared/hashtable.pas @@ -1,9 +1,8 @@ -(* Copyright (C) DooM 2D:Forever Developers +(* Copyright (C) Doom 2D: Forever Developers * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. + * the Free Software Foundation, version 3 of the License ONLY. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -26,10 +25,15 @@ unit hashtable; interface - +(* + * HashObjT: class that contains class methods: + * class function hash (const[ref] k: KeyT): LongWord; + * class function equ (const[ref] a, b: KeyT): Boolean; + * class procedure freekey (var k: KeyT); // this may free key + *) type // WARNING! don't put structures into hash, use ponters or ids! - generic THashBase = class(TObject) + generic THashBase = class(TObject) private const InitSize = {$IF DEFINED(RBHASH_SANITY_CHECKS)}16{$ELSE}256{$ENDIF}; // *MUST* be power of two const LoadFactorPrc = 90; // it is ok for robin hood hashes @@ -51,9 +55,6 @@ type property keyhash: LongWord read hash; // cannot be 0 end; - type THashFn = function (constref o: KeyT): LongWord; - type TEquFn = function (constref a, b: KeyT): Boolean; - type TFreeKeyFn = procedure (var k: KeyT); // this may free key type TFreeValueFn = procedure (var v: ValueT); // this may free value type TIteratorFn = function (constref k: KeyT; constref v: ValueT): Boolean is nested; // return `true` to stop type TIteratorExFn = function (constref k: KeyT; constref v: ValueT; keyhash: LongWord): Boolean is nested; // return `true` to stop @@ -101,9 +102,6 @@ type end; private - hashfn: THashFn; - equfn: TEquFn; - freekeyfn: TFreeKeyFn; freevalfn: TFreeValueFn; mBuckets: array of PEntry; // entries, points to mEntries elements mBucketsUsed: Integer; @@ -128,7 +126,7 @@ type procedure freeEntries (); public - constructor Create (ahashfn: THashFn; aequfn: TEquFn; afreekeyfn: TFreeKeyFn=nil; afreevalfn: TFreeValueFn=nil); + constructor Create (afreevalfn: TFreeValueFn=nil); destructor Destroy (); override; procedure clear (); @@ -181,43 +179,58 @@ type type - THashIntInt = specialize THashBase; - THashStrInt = specialize THashBase; - THashIntStr = specialize THashBase; - THashStrStr = specialize THashBase; + THashKeyInt = class + public + class function hash (const k: Integer): LongWord; inline; + class function equ (const a, b: Integer): Boolean; inline; + class procedure freekey (k: Integer); inline; + end; + + THashKeyStr = class + public + class function hash (const k: AnsiString): LongWord; inline; + class function equ (const a, b: AnsiString): Boolean; inline; + class procedure freekey (var k: AnsiString); inline; + end; + // case-insensitive (ansi) + THashKeyStrAnsiCI = class + public + class function hash (const k: AnsiString): LongWord; inline; + class function equ (const a, b: AnsiString): Boolean; inline; + class procedure freekey (var k: AnsiString); inline; + end; -function hashNewIntInt (): THashIntInt; -function hashNewStrInt (): THashStrInt; -function hashNewIntStr (): THashIntStr; -function hashNewStrStr (): THashStrStr; +type + THashIntInt = specialize THashBase; + THashStrInt = specialize THashBase; + THashStrCIInt = specialize THashBase; + THashIntStr = specialize THashBase; + THashStrStr = specialize THashBase; + THashStrCIStr = specialize THashBase; + THashStrVariant = specialize THashBase; + THashStrCIVariant = specialize THashBase; function u32Hash (a: LongWord): LongWord; inline; function fnvHash (constref buf; len: LongWord): LongWord; -function joaatHash (constref buf; len: LongWord): LongWord; +function joaatHash (constref buf; len: LongWord; seed: LongWord=0): LongWord; +function joaatHashPtr (buf: Pointer; len: LongWord; seed: LongWord=0): LongWord; -function nextPOT (x: LongWord): LongWord; inline; - - -// for integer keys -function hashIntEqu (constref a, b: Integer): Boolean; -function hashIntHash (constref k: Integer): LongWord; -function hashStrEqu (constref a, b: AnsiString): Boolean; -function hashStrHash (constref k: AnsiString): LongWord; -procedure hashStrFree (var s: AnsiString); +// has to be public due to FPC generics limitation +function nextPOTU32 (x: LongWord): LongWord; inline; implementation uses - SysUtils; + SysUtils, Variants; // ////////////////////////////////////////////////////////////////////////// // {$PUSH} {$RANGECHECKS OFF} -function nextPOT (x: LongWord): LongWord; inline; +function nextPOTU32 (x: LongWord): LongWord; inline; begin result := x; result := result or (result shr 1); @@ -231,56 +244,6 @@ end; {$POP} -// ////////////////////////////////////////////////////////////////////////// // -function hashIntEqu (constref a, b: Integer): Boolean; begin result := (a = b); end; -function hashStrEqu (constref a, b: AnsiString): Boolean; begin result := (a = b); end; -procedure hashStrFree (var s: AnsiString); begin s := ''; end; - -{$PUSH} -{$RANGECHECKS OFF} -function hashIntHash (constref k: Integer): LongWord; -begin - result := LongWord(k); - result -= (result shl 6); - result := result xor (result shr 17); - result -= (result shl 9); - result := result xor (result shl 4); - result -= (result shl 3); - result := result xor (result shl 10); - result := result xor (result shr 15); -end; - -function hashStrHash (constref k: AnsiString): LongWord; -begin - if (Length(k) > 0) then result := fnvHash(PAnsiChar(k)^, Length(k)) else result := 0; -end; -{$POP} - - -function hashNewIntInt (): THashIntInt; -begin - result := THashIntInt.Create(hashIntHash, hashIntEqu); -end; - - -function hashNewStrInt (): THashStrInt; -begin - result := THashStrInt.Create(hashStrHash, hashStrEqu, hashStrFree); -end; - - -function hashNewIntStr (): THashIntStr; -begin - result := THashIntStr.Create(hashIntHash, hashIntEqu, nil, hashStrFree); -end; - - -function hashNewStrStr (): THashStrStr; -begin - result := THashStrStr.Create(hashStrHash, hashStrEqu, hashStrFree, hashStrFree); -end; - - // ////////////////////////////////////////////////////////////////////////// // {$PUSH} {$RANGECHECKS OFF} @@ -289,20 +252,17 @@ begin reset(aseed); end; - procedure TJoaatHasher.reset (); inline; overload; begin hash := seed; end; - procedure TJoaatHasher.reset (aseed: LongWord); inline; overload; begin seed := aseed; hash := aseed; end; - procedure TJoaatHasher.put (constref buf; len: LongWord); var bytes: PByte; @@ -322,7 +282,6 @@ begin hash := h; end; - function TJoaatHasher.value: LongWord; inline; begin result := hash; @@ -333,17 +292,50 @@ end; {$POP} -function joaatHash (constref buf; len: LongWord): LongWord; +// ////////////////////////////////////////////////////////////////////////// // +{$PUSH} +{$RANGECHECKS OFF} +function joaatHash (constref buf; len: LongWord; seed: LongWord=0): LongWord; var - h: TJoaatHasher; + b: PByte; + f: LongWord; begin - h := TJoaatHasher.Create(0); - h.put(PByte(@buf)^, len); - result := h.value; + result := seed; + b := PByte(@buf); + for f := 1 to len do + begin + result += b^; + result += (result shl 10); + result := result xor (result shr 6); + Inc(b); + end; + // finalize + result += (result shl 3); + result := result xor (result shr 11); + result += (result shl 15); end; +function joaatHashPtr (buf: Pointer; len: LongWord; seed: LongWord=0): LongWord; +var + b: PByte; + f: LongWord; +begin + result := seed; + b := PByte(buf); + for f := 1 to len do + begin + result += b^; + result += (result shl 10); + result := result xor (result shr 6); + Inc(b); + end; + // finalize + result += (result shl 3); + result := result xor (result shr 11); + result += (result shl 15); +end; +{$POP} -// ////////////////////////////////////////////////////////////////////////// // {$PUSH} {$RANGECHECKS OFF} // fnv-1a: http://www.isthe.com/chongo/tech/comp/fnv/ @@ -363,7 +355,6 @@ begin end; {$POP} - {$PUSH} {$RANGECHECKS OFF} function u32Hash (a: LongWord): LongWord; inline; @@ -379,6 +370,90 @@ begin end; {$POP} +function locase1251 (ch: AnsiChar): AnsiChar; inline; +begin + if ch < #128 then + begin + if (ch >= 'A') and (ch <= 'Z') then Inc(ch, 32); + end + else + begin + if (ch >= #192) and (ch <= #223) then + begin + Inc(ch, 32); + end + else + begin + case ch of + #168, #170, #175: Inc(ch, 16); + #161, #178: Inc(ch); + end; + end; + end; + result := ch; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +// THashKeyInt +class function THashKeyInt.hash (const k: Integer): LongWord; inline; +begin + result := LongWord(k); + result -= (result shl 6); + result := result xor (result shr 17); + result -= (result shl 9); + result := result xor (result shl 4); + result -= (result shl 3); + result := result xor (result shl 10); + result := result xor (result shr 15); +end; + +class function THashKeyInt.equ (const a, b: Integer): Boolean; inline; begin result := (a = b); end; +class procedure THashKeyInt.freekey (k: Integer); inline; begin end; + + +// ////////////////////////////////////////////////////////////////////////// // +// THashKeyStr +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; +class function THashKeyStr.equ (const a, b: AnsiString): Boolean; inline; begin result := (a = b); end; +class procedure THashKeyStr.freekey (var k: AnsiString); inline; begin k := ''; end; + + +// ////////////////////////////////////////////////////////////////////////// // +// case-insensitive (ansi) +{$PUSH} +{$RANGECHECKS OFF} +// fnv-1a: http://www.isthe.com/chongo/tech/comp/fnv/ +function fnvHashLo (constref buf; len: LongWord): LongWord; +var + b: PAnsiChar; +begin + b := @buf; + result := 2166136261; // fnv offset basis + while (len > 0) do + begin + result := result xor Byte(locase1251(b^)); + result := result*16777619; // 32-bit fnv prime + Inc(b); + Dec(len); + end; +end; +{$POP} + +class function THashKeyStrAnsiCI.hash (const k: AnsiString): LongWord; inline; begin if (Length(k) > 0) then result := fnvHashLo((@k[1])^, Length(k)) else result := 0; end; +class function THashKeyStrAnsiCI.equ (const a, b: AnsiString): Boolean; inline; +var + f: Integer; +begin + result := false; + if (Length(a) = Length(b)) then + begin + for f := 1 to Length(a) do if (locase1251(a[f]) <> locase1251(b[f])) then exit; + end; + result := true; +end; +class procedure THashKeyStrAnsiCI.freekey (var k: AnsiString); inline; begin k := ''; end; + // ////////////////////////////////////////////////////////////////////////// // function THashBase.TEntry.getEmpty (): Boolean; inline; begin result := (hash = 0); end; @@ -388,17 +463,12 @@ function THashBase.TEntry.getEmpty (): Boolean; inline; begin result := (hash = function THashBase.getCapacity (): Integer; inline; begin result := Length(mBuckets); end; -constructor THashBase.Create (ahashfn: THashFn; aequfn: TEquFn; afreekeyfn: TFreeKeyFn=nil; afreevalfn: TFreeValueFn=nil); +constructor THashBase.Create (afreevalfn: TFreeValueFn=nil); begin - if not assigned(ahashfn) then raise Exception.Create('cannot create hash without hash function'); - if not assigned(aequfn) then raise Exception.Create('cannot create hash without equality function'); - - hashfn := ahashfn; - equfn := aequfn; - freekeyfn := afreekeyfn; freevalfn := afreevalfn; mSeed := u32Hash($29a); + mFreeEntryHead := nil; mFirstEntry := -1; mLastEntry := -1; clear(); @@ -407,6 +477,7 @@ end; destructor THashBase.Destroy (); begin + freeEntries(); mBuckets := nil; mEntries := nil; inherited; @@ -425,8 +496,8 @@ begin e := @mEntries[f]; if not e.empty then begin - if assigned(freekeyfn) then freekeyfn(e.key); - if assigned(freevalfn) then freevalfn(e.value); + HashObjT.freekey(e.key); + if assigned(freevalfn) then freevalfn(e.value) else e.value := Default(ValueT); e.key := Default(KeyT); e.value := Default(ValueT); e.hash := 0; @@ -447,14 +518,19 @@ end; procedure THashBase.clear (); -//var idx: Integer; begin freeEntries(); + { SetLength(mBuckets, InitSize); FillChar(mBuckets[0], InitSize*sizeof(mBuckets[0]), 0); - //for idx := 0 to High(mBuckets) do mBuckets[idx] := nil; SetLength(mEntries, InitSize); FillChar(mEntries[0], InitSize*sizeof(mEntries[0]), 0); + } + mFreeEntryHead := nil; + mBuckets := nil; + mEntries := nil; + mFirstEntry := -1; + mLastEntry := -1; mBucketsUsed := 0; end; @@ -478,6 +554,21 @@ var begin if (mFreeEntryHead = nil) then begin + // nothing was allocated, so allocate something now + if (Length(mBuckets) = 0) then + begin + assert(Length(mEntries) = 0); + assert(mFirstEntry = -1); + assert(mLastEntry = -1); + assert(mBucketsUsed = 0); + {$IFDEF RBHASH_SANITY_CHECKS} + mEntriesUsed := 0; + {$ENDIF} + SetLength(mBuckets, InitSize); + FillChar(mBuckets[0], InitSize*sizeof(mBuckets[0]), 0); + SetLength(mEntries, InitSize); + FillChar(mEntries[0], InitSize*sizeof(mEntries[0]), 0); + end; if (mLastEntry = High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (0.0)'); Inc(mLastEntry); if (mFirstEntry = -1) then @@ -528,8 +619,8 @@ begin if (idx < 0) or (idx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid entry address)'); if (e <> @mEntries[idx]) then raise Exception.Create('internal error in hash entry allocator (wtf?!)'); {$ENDIF} - if assigned(freekeyfn) then freekeyfn(e.key); - if assigned(freevalfn) then freevalfn(e.value); + HashObjT.freekey(e.key); + if assigned(freevalfn) then freevalfn(e.value) else e.value := Default(ValueT); {$IFDEF RBHASH_SANITY_CHECKS} Dec(mEntriesUsed); {$ENDIF} @@ -606,11 +697,11 @@ begin if (keyhashin <> nil) then begin khash := keyhashin^; - if (khash = 0) then khash := hashfn(akey); + if (khash = 0) then khash := HashObjT.hash(akey); end else begin - khash := hashfn(akey); + khash := HashObjT.hash(akey); end; if (khash = 0) then khash := $29a; @@ -622,7 +713,7 @@ begin if (mBuckets[idx] = nil) then break; pdist := distToStIdx(idx); if (dist > pdist) then break; - result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey); + result := (mBuckets[idx].hash = khash) and HashObjT.equ(mBuckets[idx].key, akey); if result then break; idx := (idx+1) and bhigh; end; @@ -644,11 +735,11 @@ begin if (keyhashin <> nil) then begin khash := keyhashin^; - if (khash = 0) then khash := hashfn(akey); + if (khash = 0) then khash := HashObjT.hash(akey); end else begin - khash := hashfn(akey); + khash := HashObjT.hash(akey); end; if (khash = 0) then khash := $29a; @@ -659,7 +750,7 @@ begin if (mBuckets[idx] = nil) then break; pdist := distToStIdx(idx); if (dist > pdist) then break; - result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey); + result := (mBuckets[idx].hash = khash) and HashObjT.equ(mBuckets[idx].key, akey); if result then begin rval := mBuckets[idx].value; break; end; idx := (idx+1) and bhigh; end; @@ -715,7 +806,7 @@ begin bhigh := High(mBuckets); xseed := mSeed; - khash := hashfn(akey); + khash := HashObjT.hash(akey); if (khash = 0) then khash := $29a; if (keyhashout <> nil) then keyhashout^ := khash; idx := (khash xor xseed) and bhigh; @@ -728,12 +819,12 @@ begin if (mBuckets[idx] = nil) then break; pdist := distToStIdx(idx); if (dist > pdist) then break; - result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey); + result := (mBuckets[idx].hash = khash) and HashObjT.equ(mBuckets[idx].key, akey); if result then begin // replace element - if assigned(freekeyfn) then freekeyfn(mBuckets[idx].key); - if assigned(freevalfn) then freevalfn(mBuckets[idx].value); + HashObjT.freekey(mBuckets[idx].key); + if assigned(freevalfn) then freevalfn(mBuckets[idx].value) else mBuckets[idx].value := Default(ValueT); mBuckets[idx].key := akey; mBuckets[idx].value := aval; exit; @@ -786,11 +877,11 @@ begin if (keyhashin <> nil) then begin khash := keyhashin^; - if (khash = 0) then khash := hashfn(akey); + if (khash = 0) then khash := HashObjT.hash(akey); end else begin - khash := hashfn(akey); + khash := HashObjT.hash(akey); end; if (khash = 0) then khash := $29a; @@ -803,7 +894,7 @@ begin if (mBuckets[idx] = nil) then break; pdist := distToStIdx(idx); if (dist > pdist) then break; - result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey); + result := (mBuckets[idx].hash = khash) and HashObjT.equ(mBuckets[idx].key, akey); if result then break; idx := (idx+1) and bhigh; end; @@ -873,7 +964,6 @@ begin if (cnt = mBucketsUsed) and (idx <> mLastEntry) then raise Exception.Create('internal error in rehash: inconsistent (2)'); {$ENDIF} // no need to recalculate hash - //e.hash := hashfn(e.key) xor mSeed; if (e.hash = 0) then e.hash := $29a; putEntryInternal(e); end else @@ -882,7 +972,7 @@ begin lastfree := e; end; end; - if (lastfree <> nil) then e.nextFree := nil; + if (lastfree <> nil) then lastfree.nextFree := nil; {$IFDEF RBHASH_SANITY_CHECKS} if (cnt <> mBucketsUsed) then raise Exception.Create('internal error in hash table resize (invalid first/last range; 0)'); if (cnt <> mEntriesUsed) then raise Exception.Create('internal error in hash table resize (invalid first/last range; 1)'); @@ -897,7 +987,7 @@ var cnt: Integer; {$ENDIF} begin - newsz := nextPOT(LongWord(mBucketsUsed)); + newsz := nextPOTU32(LongWord(mBucketsUsed)); if (newsz >= 1024*1024*1024) then exit; if (newsz*2 >= Length(mBuckets)) then exit; if (newsz*2 < 128) then exit;