diff options
Diffstat (limited to 'src/corelib/fpg_stringhashlist.pas')
-rw-r--r-- | src/corelib/fpg_stringhashlist.pas | 333 |
1 files changed, 333 insertions, 0 deletions
diff --git a/src/corelib/fpg_stringhashlist.pas b/src/corelib/fpg_stringhashlist.pas new file mode 100644 index 00000000..15bd36fd --- /dev/null +++ b/src/corelib/fpg_stringhashlist.pas @@ -0,0 +1,333 @@ +{ + fpGUI - Free Pascal GUI Library + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + This file was originally part of the Lazarus Component Library (LCL). + Thanks to Markus Waldenburg. + + Ported this unit to fpGUI by Graeme Geldenhuys. + TStringHashList is supposed to be faster than FPC's TFPObjectHashTable. + This unit is used in fpg_pofile unit. +} + +unit fpg_stringhashlist; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, fpg_constants; + +type + PStringHashItem = ^TStringHashItem; + TStringHashItem = record + HashValue: Cardinal; + Key: String; + Data: Pointer; + end; + + PStringHashItemList = ^PStringHashItem; + + TStringHashList = class(TObject) + private + FList: PStringHashItemList; + FCount: Integer; + fCaseSensitive: Boolean; + function CompareString(const Value1, Value2: String): Boolean; + function CompareValue(const Value1, Value2: Cardinal): Integer; + function GetData(const S: String): Pointer; + procedure SetCaseSensitive(const Value: Boolean); + procedure Delete(Index: Integer); + procedure SetData(const S: String; const AValue: Pointer); + protected + function HashOf(const Key: string): Cardinal; + procedure Insert(Index: Integer; Item: PStringHashItem); + public + constructor Create(CaseSensitivity: boolean); + destructor Destroy; override; + function Add(const S: String): Integer; + function Add(const S: String; ItemData: Pointer): Integer; + procedure Clear; + function Find(const S: String): Integer; + function Remove(const S: String): Integer; + property CaseSensitive: Boolean read fCaseSensitive write SetCaseSensitive; + property Count: Integer read FCount; + property Data[const S: String]: Pointer read GetData write SetData; default; + property List: PStringHashItemList read FList; + end; + + +implementation + +var + UpperCaseChars: array[char] of char; + +{ TStringHashList } + +function TStringHashList.Add(const S: String): Integer; +begin + Result:=Add(S,nil); +end; + +function TStringHashList.Add(const S: String; ItemData: Pointer): Integer; +var + Item: PStringHashItem; + First, Last, I: Integer; + Val: Cardinal; + Larger: boolean; +begin + New(Item); + Val:= HashOf(S); + Item^.HashValue := Val; + Item^.Key := S; + Item^.Data := ItemData; + if FCount > 0 then + begin + First:=0; + Last:= FCount-1; + Larger:=False; + while First<=Last do + begin + I:=(First+Last)shr 1; + Case CompareValue(Val, fList[I]^.HashValue)<=0 of + True: + begin + Last:=I-1; + Larger:=False; + end; + False: + begin + First:=I+1; + Larger:=True; + end; + end; + end; + Case Larger of + True: Result:=I+1; + False: Result:=I; + end; + end else + Result:=0; + Insert(Result,Item); +end; + +procedure TStringHashList.Clear; +var + I: Integer; +begin + if fCount = 0 then exit; + for I:= 0 to fCount -1 do + Dispose(fList[I]); + if FList<>nil then begin + FreeMem(FList); + FList:=nil; + end; + fCount:= 0; +end; + +function TStringHashList.CompareString(const Value1, Value2: String): Boolean; +var + I, Len: Integer; + P1,P2: PChar; +begin + Result:= False; + P1:= PChar(Value1); + Len:= Length(Value1); + P2:= PChar(Value2); + if Len = Length(Value2) then + begin + Result:= True; + case fCaseSensitive of + True: + for I:= Len -1 downto 0 do + if P1[I] <> P2[I] then begin + Result:= False; + break; + end; + False: + for I:= Len -1 downto 0 do + if UpperCaseChars[P1[I]] <> UpperCaseChars[P2[I]] then begin + Result:= False; + break; + end; + end; + end; +end; + +function TStringHashList.CompareValue(const Value1, Value2: Cardinal): Integer; +begin + Result:= 0; + if Value1 > Value2 then + Result:= 1 + else if Value1 < Value2 then + Result:= -1; +end; + +function TStringHashList.GetData(const S: String): Pointer; +var i: integer; +begin + i:=Find(S); + if i>=0 then + Result:=FList[i]^.Data + else + Result:=nil; +end; + +procedure TStringHashList.Delete(Index: Integer); +begin + if (Index >= 0) and (Index < FCount) then + begin + dec(FCount); + if Index < FCount then + System.Move(FList[Index + 1], FList[Index], + (FCount - Index) * SizeOf(PStringHashItem)); + end; +end; + +procedure TStringHashList.SetData(const S: String; const AValue: Pointer); +var i: integer; +begin + i:=Find(S); + if i>=0 then + FList[i]^.Data:=AValue + else + Add(S,AValue); +end; + +destructor TStringHashList.Destroy; +begin + Clear; + inherited Destroy; +end; + +function TStringHashList.Find(const S: String): Integer; +var + Value: Integer; + First, Last, Temp, I: Integer; +begin + Value:= HashOf(s); + Result:= -1; + First:= 0; + Last:= Count -1; + while First <= Last do + begin + Temp:= (First + Last) div 2; + case CompareValue(Value, FList[Temp]^.HashValue) of + 1: First:= Temp +1; + 0: + begin + Result:= Temp; + if CompareString(S, FList[Temp]^.Key) then + exit + else + break; + end; + -1: Last:= Temp-1; + end; + end; + if Result <> -1 then + begin + Result:= -1; + First:= Temp -1; + if First > 0 then + while CompareValue(Value, FList[First]^.HashValue) = 0 do + dec(First); + inc(First); + Last:= Temp +1; + if Last < Count -1 then + while CompareValue(Value, FList[Last]^.HashValue) = 0 do + inc(Last); + dec(Last); + for I:= First to Last do + if CompareString(S, FList[I]^.Key) then + begin + Result:= I; + Exit; + end; + end; +end; + +function TStringHashList.HashOf(const Key: string): Cardinal; +var + P: PChar; + I, Len: Integer; +begin + P:= PChar(Key); + Len:= Length(Key); + Result := Len; + // use the last 30 characters to compute the hash + case fCaseSensitive of + True: + for I:= Len -1 downto 0 do + inc(Result, cardinal(ord(P[I])) shl I); + False: + for I:= Len -1 downto 0 do + inc(Result, cardinal(ord(UpperCaseChars[P[I]])) shl I); + end; +end; + +procedure TStringHashList.Insert(Index: Integer; Item: PStringHashItem); +begin + ReallocMem(FList, (fCount +1) * SizeOf(PStringHashItem)); + if Index > fCount then Index:= fCount; + if Index < 0 then Index:= 0; + if Index < FCount then + System.Move(FList[Index], FList[Index + 1], + (FCount - Index) * SizeOf(PStringHashItem)); + FList[Index] := Item; + Inc(FCount); +end; + +constructor TStringHashList.Create(CaseSensitivity: boolean); +begin + fCaseSensitive:=CaseSensitivity; + inherited Create; +end; + +function TStringHashList.Remove(const S: String): Integer; +begin + Result:= Find(S); + if Result > -1 then + begin + Dispose(fList[Result]); + Delete(Result); + end; +end; + +procedure TStringHashList.SetCaseSensitive(const Value: Boolean); +begin + if fCaseSensitive <> Value then + begin + if Count > 0 then + begin + raise EListError.Create(rsErrListMustBeEmpty); + exit; + end; + fCaseSensitive := Value; + end; +end; + +//------------------------------------------------------------------------------ +procedure InternalInit; +var c: char; +begin + for c:=Low(char) to High(char) do begin + UpperCaseChars[c]:=upcase(c); + end; +end; + +initialization + InternalInit; + +end. |