diff --git a/.gitattributes b/.gitattributes index c90a37dde3..2eff0d6415 100644 --- a/.gitattributes +++ b/.gitattributes @@ -2865,6 +2865,11 @@ components/lazutils/examples/DictionaryStringList/TDictionaryStringListDemo.lpi components/lazutils/examples/DictionaryStringList/TDictionaryStringListDemo.lpr svneol=native#text/plain components/lazutils/examples/DictionaryStringList/main.lfm svneol=native#text/plain components/lazutils/examples/DictionaryStringList/main.pas svneol=native#text/plain +components/lazutils/examples/LookupStringList/ReadMe.txt svneol=native#text/plain +components/lazutils/examples/LookupStringList/TDedupeDemo.lpi svneol=native#text/plain +components/lazutils/examples/LookupStringList/TDedupeDemo.lpr svneol=native#text/pascal +components/lazutils/examples/LookupStringList/main.lfm svneol=native#text/plain +components/lazutils/examples/LookupStringList/main.pas svneol=native#text/pascal components/lazutils/fileutil.inc svneol=native#text/pascal components/lazutils/fileutil.pas svneol=native#text/pascal components/lazutils/fpcadds.pas svneol=native#text/pascal @@ -2930,6 +2935,7 @@ components/lazutils/lazutils.pas svneol=native#text/pascal components/lazutils/lazutilsstrconsts.pas svneol=native#text/pascal components/lazutils/lconvencoding.pas svneol=native#text/pascal components/lazutils/lcsvutils.pas svneol=native#text/pascal +components/lazutils/lookupstringlist.pas svneol=native#text/pascal components/lazutils/masks.pas svneol=native#text/pascal components/lazutils/paswstring.pas svneol=native#text/pascal components/lazutils/test/TestLazStorageMem.lpi svneol=native#text/plain @@ -4560,6 +4566,7 @@ docs/xml/lazutils/lazutilities.xml svneol=native#text/plain docs/xml/lazutils/lazutils.xml svneol=native#text/plain docs/xml/lazutils/lazutilsstrconsts.xml svneol=native#text/plain docs/xml/lazutils/lconvencoding.xml svneol=native#text/plain +docs/xml/lazutils/lookupstringlist.xml svneol=native#text/plain docs/xml/lazutils/masks.xml svneol=native#text/plain docs/xml/lazutils/paswstring.xml svneol=native#text/plain docs/xml/lazutils/ttcache.xml svneol=native#text/plain diff --git a/components/lazutils/examples/LookupStringList/ReadMe.txt b/components/lazutils/examples/LookupStringList/ReadMe.txt new file mode 100644 index 0000000000..0e322b3d43 --- /dev/null +++ b/components/lazutils/examples/LookupStringList/ReadMe.txt @@ -0,0 +1,3 @@ +Demonstrate how TLookupStringList can quickly remove duplicates from a list without changing the order. + +Author: Antônio Galvão diff --git a/components/lazutils/examples/LookupStringList/TDedupeDemo.lpi b/components/lazutils/examples/LookupStringList/TDedupeDemo.lpi new file mode 100644 index 0000000000..0671867312 --- /dev/null +++ b/components/lazutils/examples/LookupStringList/TDedupeDemo.lpi @@ -0,0 +1,83 @@ + + + + + + + + + + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="TDedupeDemo.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="main.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Main"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="TDedupeDemo"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/components/lazutils/examples/LookupStringList/TDedupeDemo.lpr b/components/lazutils/examples/LookupStringList/TDedupeDemo.lpr new file mode 100644 index 0000000000..626f56d10c --- /dev/null +++ b/components/lazutils/examples/LookupStringList/TDedupeDemo.lpr @@ -0,0 +1,20 @@ +program TDedupeDemo; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Main; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/components/lazutils/examples/LookupStringList/main.lfm b/components/lazutils/examples/LookupStringList/main.lfm new file mode 100644 index 0000000000..b147a1a7f4 --- /dev/null +++ b/components/lazutils/examples/LookupStringList/main.lfm @@ -0,0 +1,90 @@ +object Form1: TForm1 + Left = 353 + Height = 353 + Top = 194 + Width = 535 + BorderStyle = bsSingle + Caption = 'TLookupStringList Demo' + ClientHeight = 353 + ClientWidth = 535 + OnCreate = FormCreate + OnDestroy = FormDestroy + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.5' + object btnDedupeMemo: TButton + Left = 346 + Height = 25 + Top = 72 + Width = 183 + Anchors = [akTop, akRight] + Caption = 'Dedupe Memo' + OnClick = btnDedupeMemoClick + TabOrder = 0 + end + object Memo: TMemo + Left = 0 + Height = 281 + Top = 72 + Width = 336 + ScrollBars = ssAutoBoth + TabOrder = 1 + end + object lblTime: TLabel + Left = 16 + Height = 17 + Top = 48 + Width = 32 + Caption = 'Time:' + ParentColor = False + end + object lblLines: TLabel + Left = 130 + Height = 17 + Top = 48 + Width = 98 + Caption = 'Duplicated Lines:' + ParentColor = False + end + object SpinEdit1: TSpinEdit + Left = 8 + Height = 23 + Top = 8 + Width = 94 + Increment = 1000 + MaxValue = 1000000000 + TabOrder = 2 + end + object btnGenerate: TButton + Left = 112 + Height = 25 + Top = 8 + Width = 125 + Caption = 'Generate Data' + OnClick = btnGenerateClick + TabOrder = 3 + end + object btnDedupeFile: TButton + AnchorSideLeft.Control = btnDedupeMemo + AnchorSideRight.Control = btnDedupeMemo + AnchorSideRight.Side = asrBottom + Left = 346 + Height = 32 + Top = 232 + Width = 183 + Anchors = [akTop, akLeft, akRight] + Caption = 'Create File and Dedupe it' + OnClick = btnDedupeFileClick + TabOrder = 4 + end + object Label1: TLabel + Left = 346 + Height = 64 + Top = 168 + Width = 182 + AutoSize = False + Caption = 'Deduplicating from a file is very much faster than using a GUI control. Use the button below to see the whole process.' + ParentColor = False + WordWrap = True + end +end diff --git a/components/lazutils/examples/LookupStringList/main.pas b/components/lazutils/examples/LookupStringList/main.pas new file mode 100644 index 0000000000..fd92346c3c --- /dev/null +++ b/components/lazutils/examples/LookupStringList/main.pas @@ -0,0 +1,154 @@ +unit Main; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Math, Forms, Controls, Dialogs, StdCtrls, Spin, + LookupStringList; + +type + + { TForm1 } + + TForm1 = class(TForm) + btnDedupeMemo: TButton; + btnDedupeFile: TButton; + btnGenerate: TButton; + Label1 :TLabel; + lblLines: TLabel; + lblTime: TLabel; + Memo: TMemo; + SpinEdit1: TSpinEdit; + procedure btnDedupeFileClick(Sender: TObject); + procedure btnGenerateClick(Sender: TObject); + procedure btnDedupeMemoClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure FormShow(Sender: TObject); + private + inList :TStringList; + procedure UpdateDuplicates(aDuplicateCount: string); + procedure UpdateTime(aTime: TDateTime); + public + + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +{ TForm1 } + +procedure TForm1.UpdateDuplicates(aDuplicateCount: string); +begin + lblLines.Caption := 'Duplicated Lines: ' + aDuplicateCount; +end; + +procedure TForm1.UpdateTime(aTime: TDateTime); +begin + lblTime.Caption := 'Time: ' + TimeToStr(aTime); +end; + +procedure TForm1.btnGenerateClick(Sender: TObject); +var + i, j: Integer; + s :string; +begin + UpdateDuplicates('?'); + UpdateTime(0); + Memo.Clear; + Application.ProcessMessages; + Screen.Cursor := crHourGlass; + try + InList.Clear; + for i := 0 to SpinEdit1.Value - 1 do + begin + s := ''; + for j := 0 to 5 do + s := s + chr(randomrange(97, 123)); + InList.Add(s); + end; + Memo.Lines.Assign(inList); + finally + Screen.Cursor := crDefault; + end; +end; + +procedure TForm1.btnDedupeMemoClick(Sender: TObject); +var + DSL :TLookupStringList; + T :TDateTime; +begin + Screen.Cursor := crHourGlass; + try + T := Now; + DSL := TLookupStringList.Create; + try + DSL.Assign(Memo.Lines); + UpdateDuplicates(IntToStr(Memo.Lines.Count - DSL.Count)); + Memo.Lines.Assign(DSL); + finally + DSL.Free; + end; + UpdateTime(Now - T); + finally + Screen.Cursor := crDefault; + end; +end; + +procedure TForm1.btnDedupeFileClick(Sender: TObject); +var + T :TDateTime; + N :integer; + DSL :TLookupStringList; +begin + lblTime.Caption := 'Time:'; + lblLines.Caption := 'Duplicated lines:'; + Application.ProcessMessages; + + if Trim(Memo.Text) = '' then + begin + ShowMessage('Generating data. Please wait.'); + btnGenerateClick(nil); + end; + + ShowMessage('Saving memo to a file. Please wait.'); + Memo.Lines.SaveToFile('temp.txt'); + ShowMessage('Dedupping the file.'); + T := Now; + N := Memo.Lines.Count; + DSL := TLookupStringList.Create; + try + DSL.LoadFromFile('temp.txt'); + lblLines.Caption := 'Duplicated Lines: ' + IntToStr(N - DSL.Count); + DSL.SaveToFile('temp.txt'); + lblTime.Caption := 'Time: ' + TimeToStr(Now - T); + ShowMessage('Deleting the file.'); + DeleteFile('temp.txt'); + finally + DSL.Free; + end; +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + inList := TStringList.Create; + Randomize; +end; + +procedure TForm1.FormDestroy(Sender: TObject); +begin + inList.Free; +end; + +procedure TForm1.FormShow(Sender: TObject); +begin + spinedit1.Value := 100000; +end; + +end. diff --git a/components/lazutils/lookupstringlist.pas b/components/lazutils/lookupstringlist.pas new file mode 100644 index 0000000000..331aadb87c --- /dev/null +++ b/components/lazutils/lookupstringlist.pas @@ -0,0 +1,169 @@ +{ + ***************************************************************************** + This file is part of the Lazarus Component Library (LCL) + + See the file COPYING.modifiedLGPL.txt, included in this distribution, + for details about the license. + ***************************************************************************** + + Author: Juha Manninen / Antônio Galvão + + Abstract: + This is an unsorted StringList with a fast lookup feature. + Internally it uses a map container to store the strings again + which is then used for Contains, IndexOf and Find methods. + + The extra container does not reserve too much memory because the strings are + reference counted and not really copied. + + All Duplicates property values are fully supported, + including dupIgnore and dupError, unlike in unsorted StringList. + + This class is useful only when you must preserve the order in list, but + also need to do fast lookups to see if a string exists, or must prevent duplicates. +} +unit LookupStringList; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, AvgLvlTree; + +type + + { TLookupStringList } + + TLookupStringList = class(TStringList) + private + FMap: TStringMap; + protected + procedure InsertItem(Index: Integer; const S: string); override; + public + constructor Create; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + function Add(const S: string): Integer; override; + function AddObject(const S: string; AObject: TObject): Integer; override; + function Contains(const S: string): Boolean; // A new function + function Find(const S: string; out Index: Integer): Boolean; override; + function IndexOf(const S: string): Integer; override; + end; + + TDictionaryStringList = class(TLookupStringList) + end deprecated 'The class was renamed to TLookupStringList.'; + +function Deduplicate(AStrings: TStrings): Boolean; + +implementation + +{ + Removes duplicate strings (case sensitive) from AStrings. + When the AStrings owns and contains objects, the function will return false. +} +function Deduplicate(AStrings: TStrings): Boolean; +var + DSL: TLookupStringList; +begin + Result := False; + DSL := TLookupStringList.Create; + try + DSL.Assign(AStrings); + AStrings.Assign(DSL); + Result := True; + finally + DSL.Free; + end; +end; + +{ TLookupStringList } + +constructor TLookupStringList.Create; +begin + inherited Create; + FMap := TStringMap.Create(True); +end; + +destructor TLookupStringList.Destroy; +begin + FMap.Free; + inherited Destroy; +end; + +procedure TLookupStringList.Assign(Source: TPersistent); +begin + inherited Assign(Source); + if Source is TLookupStringList then + FMap.Assign(TLookupStringList(Source).FMap); +end; + +procedure TLookupStringList.Clear; +begin + inherited Clear; + FMap.Clear; +end; + +procedure TLookupStringList.Delete(Index: Integer); +var + s: String; +begin + s := Strings[Index]; + inherited Delete(Index); + // The string must not be deleted from map if there are duplicates. + // Calling IndexOf is slow but it is needed. + if (Duplicates <> dupAccept) or (inherited IndexOf(s) = -1) then + FMap.Remove(s); +end; + +function TLookupStringList.Add(const S: string): Integer; +begin + if not Sorted and (Duplicates = dupIgnore) and FMap.Contains(S) then + Result := -1 + else + Result := inherited Add(S); +end; + +function TLookupStringList.AddObject(const S: string; AObject: TObject): Integer; +begin + Result := Add(S); + if Result > -1 then + Objects[Result] := AObject; +end; + +procedure TLookupStringList.InsertItem(Index: Integer; const S: string); +begin + if not Sorted and (Duplicates <> dupAccept) then + if FMap.Contains(S) then + case Duplicates of + DupIgnore : Exit; + DupError : raise Exception.Create('TLookupStringList.InsertItem:' + +' Duplicates are not allowed.'); + end; + inherited InsertItem(Index, S); + FMap.Add(S); // Insert string to map, too. +end; + +function TLookupStringList.Contains(const S: string): Boolean; +begin + Result := FMap.Contains(S); +end; + +function TLookupStringList.Find(const S: string; out Index: Integer): Boolean; +begin + Index := IndexOf(S); + Result := Index <> -1; +end; + +function TLookupStringList.IndexOf(const S: string): Integer; +begin + if FMap.Contains(S) then + Result := inherited IndexOf(S) + else + Result := -1 +end; + +end. + diff --git a/docs/xml/lazutils/lookupstringlist.xml b/docs/xml/lazutils/lookupstringlist.xml new file mode 100644 index 0000000000..5123eaa96a --- /dev/null +++ b/docs/xml/lazutils/lookupstringlist.xml @@ -0,0 +1,245 @@ +<?xml version="1.0" encoding="ISO-8859-1"?> +<fpdoc-descriptions> +<package name="lazutils"> + +<!-- + ==================================================================== + LookupStringList + ==================================================================== +--> + +<module name="LookupStringList"> +<short></short> +<descr> +</descr> + +<!-- class Visibility: default --> +<element name="TLookupStringList"> +<short></short> +<descr> +</descr> +<errors> +</errors> +<seealso> +</seealso> +</element> + +<!-- variable Visibility: private --> +<element name="TLookupStringList.FMap"> +<short></short> +<descr> +</descr> +<seealso> +</seealso> +</element> + +<!-- procedure Visibility: protected --> +<element name="TLookupStringList.InsertItem"> +<short></short> +<descr> +</descr> +<errors> +</errors> +<seealso> +</seealso> +</element> + +<!-- argument Visibility: default --> +<element name="TLookupStringList.InsertItem.Index"> +<short></short> +</element> + +<!-- argument Visibility: default --> +<element name="TLookupStringList.InsertItem.S"> +<short></short> +</element> + +<!-- argument Visibility: default --> +<element name="TLookupStringList.InsertItem.O"> +<short></short> +</element> + +<!-- constructor Visibility: public --> +<element name="TLookupStringList.Create"> +<short></short> +<descr> +</descr> +<errors> +</errors> +<seealso> +</seealso> +</element> + +<!-- destructor Visibility: public --> +<element name="TLookupStringList.Destroy"> +<short></short> +<descr> +</descr> +<errors> +</errors> +<seealso> +</seealso> +</element> + +<!-- procedure Visibility: public --> +<element name="TLookupStringList.Assign"> +<short></short> +<descr> +</descr> +<errors> +</errors> +<seealso> +</seealso> +</element> + +<!-- argument Visibility: default --> +<element name="TLookupStringList.Assign.Source"> +<short></short> +</element> + +<!-- procedure Visibility: public --> +<element name="TLookupStringList.Clear"> +<short></short> +<descr> +</descr> +<errors> +</errors> +<seealso> +</seealso> +</element> + +<!-- procedure Visibility: public --> +<element name="TLookupStringList.Delete"> +<short></short> +<descr> +</descr> +<errors> +</errors> +<seealso> +</seealso> +</element> + +<!-- argument Visibility: default --> +<element name="TLookupStringList.Delete.Index"> +<short></short> +</element> + +<!-- function Visibility: public --> +<element name="TLookupStringList.Add"> +<short></short> +<descr> +</descr> +<errors> +</errors> +<seealso> +</seealso> +</element> + +<!-- function result Visibility: default --> +<element name="TLookupStringList.Add.Result"> +<short></short> +</element> + +<!-- argument Visibility: default --> +<element name="TLookupStringList.Add.S"> +<short></short> +</element> + +<!-- function Visibility: public --> +<element name="TLookupStringList.AddObject"> +<short></short> +<descr> +</descr> +<errors> +</errors> +<seealso> +</seealso> +</element> + +<!-- function result Visibility: default --> +<element name="TLookupStringList.AddObject.Result"> +<short></short> +</element> + +<!-- argument Visibility: default --> +<element name="TLookupStringList.AddObject.S"> +<short></short> +</element> + +<!-- argument Visibility: default --> +<element name="TLookupStringList.AddObject.AObject"> +<short></short> +</element> + +<!-- function Visibility: public --> +<element name="TLookupStringList.Contains"> +<short></short> +<descr> +</descr> +<errors> +</errors> +<seealso> +</seealso> +</element> + +<!-- function result Visibility: default --> +<element name="TLookupStringList.Contains.Result"> +<short></short> +</element> + +<!-- argument Visibility: default --> +<element name="TLookupStringList.Contains.S"> +<short></short> +</element> + +<!-- function Visibility: public --> +<element name="TLookupStringList.Find"> +<short></short> +<descr> +</descr> +<errors> +</errors> +<seealso> +</seealso> +</element> + +<!-- function result Visibility: default --> +<element name="TLookupStringList.Find.Result"> +<short></short> +</element> + +<!-- argument Visibility: default --> +<element name="TLookupStringList.Find.S"> +<short></short> +</element> + +<!-- argument Visibility: default --> +<element name="TLookupStringList.Find.Index"> +<short></short> +</element> + +<!-- function Visibility: public --> +<element name="TLookupStringList.IndexOf"> +<short></short> +<descr> +</descr> +<errors> +</errors> +<seealso> +</seealso> +</element> + +<!-- function result Visibility: default --> +<element name="TLookupStringList.IndexOf.Result"> +<short></short> +</element> + +<!-- argument Visibility: default --> +<element name="TLookupStringList.IndexOf.S"> +<short></short> +</element> + +</module> <!-- LookupStringList --> + +</package> +</fpdoc-descriptions>