unit SuperSort;
{This class allows sorting of TString objects with extra functionality
ala UNIX style parameters.
(Yes I know UNIX is a four letter word but they do have some neat features).
The SORT algorithm utilizes the QUICK SORT method. The features I have implemented are
Options:
Sort descending – srtDescending
Treat sort field as numeric – srtEvalNumeric
Ignore leading blanks in field – srtIgnoreBlank
Ignore case of field – srtIgnoreCase
Switches:
-k – Start,End position of substring for search
-f – Field number of a delimited string (Zero column based)
-d – Character delimiter for -f switch (Default = SPACE)
In it's simplest form the class just sorts the TStrings ascending e.g.
SuperSort.SortStrings(Memo1.Lines,[]);
Assume a semi-colon delimited list like:
'Mike;34;Green'
'harry;25;Red'
'Jackie;6;Black'
'Bazil;9,Pink'
'john;52;Blue'
To sort this list DESCENDING on AGE (Field 1) and ignore case:
SuperSort(MyStrings, ['-f 1','-d ;'],
[srtDescending,srtEvalNumeric,srtIgnoreCase]);
Assume a string list of:
'1999 12 20 AA432 Comment 1'
'2002 10 12 SWA12 Some other words'
'1998 09 11 BDS65 And so on and so on'
To sort this list on ITEM CODE (Positions 12 to 17) with no options
SuperSort(MyStrings,['-k 12,17']);
Methods:
procedure SortStrings(StringList: TStrings; Switches: array of string;
Options: TSuperSortOptionSet = []);
Switches is a string array of -k,-d and -f settings. If it is set to empty array [] then NO switches are active. Options is an OPTIONAL set of [srtDescending,srtIgnoreCase,srtIgnoreBlank,srtEvalNumeric] The default is empty set [].
Properties:
SortTime : TDateTime;
Returns the time taken for the sort for stats purposes.
Usage Example:
uses
SuperSort;
procedure TForm1.Test;
var
Srt: TSuperSort;
begin
Srt := TSuperSort.Create;
Srt.SortStrings(Memo1.Lines,[],[srtIgnoreBlank]);
Label1.Caption := 'Time : ' + FormatDateTine('hh:nn:ss:zzz',Srt.SortTime);
Srt.Free;
end;
}
interface
{$ifdef fpc}{$mode delphi}{$endif}{$H+}
uses
Classes,SysUtils;
// ==========================================================================
// Class TSuperSort
// Mike Heydon Nov 2002
//
// Sort class that implements Unix style sorts including ..
//
// SWITCHES
// --------
// -k [StartPos,EndPos] - Keyfield to sort on. Start and End pos in string
// -d [Field Delimiter] - Delimter to use with -f switch. default = SPACE
// -f [FieldNumber] - Zero based field number delimeted by -d
//
// OPTIONS SET
// ============
// srtDescending - Sort descending
// srtIgnoreCase - Ignore case when sorting
// srtIgnoreBlank - Ignore leading blanks
// srtEvalNumeric - Treat sort items as NUMERIC
//
// ==========================================================================
type
// Sort Options
TSuperSortOptions = (
srtDescending,srtIgnoreCase, srtIgnoreBlank,srtEvalNumeric
);
TSuperSortOptionSet = set of TSuperSortOptions;
// ============
// TSuperSort
// ============
TSuperSort = class(TObject)
private
FSortTime : TDateTime;
FIsSwitches,
FIsPositional,
FIsDelimited,
FDescending,
FIgnoreCase,
FIgnoreBlank,
FEvalDateTime,
FEvalNumeric : boolean;
FFieldNum,
FStartPos,FEndPos : integer;
FDelimiter : char;
protected
function GetKeyString(const Line : string) : string;
procedure QuickSortStrA(SL : TStrings);
procedure QuickSortStrD(SL : TStrings);
procedure ResolveSwitches(Switches : array of string);
public
procedure SortStrings(StringList : TStrings; Switches : array of string;
Options : TSuperSortOptionSet = []);
property SortTime : TDateTime read FSortTime;
end;
// --------------------------------------------------------------------------
implementation
const
BLANK = -1;
EMPTYSTR = '';
// ================================================
// INTERNAL CALL
// Resolve switches and set internal variables
// ================================================
procedure TSuperSort.ResolveSwitches(Switches : array of string);
var
i : integer;
Sw,Data : string;
begin
FStartPos := BLANK;
FEndPos := BLANK;
FFieldNum := BLANK;
FDelimiter := ' ';
FIsPositional := false;
FIsDelimited := false;
for i := Low(Switches) to High(Switches) do
begin
Sw := trim(Switches[i]);
Data := trim(copy(Sw,3,1024));
Sw := UpperCase(copy(Sw,1,2));
// Delimiter
if Sw = '-D' then
begin
if length(Data) > 0 then FDelimiter := Data[1];
end;
// Field Number
if Sw = '-F' then
begin
FIsSwitches := true;
FIsDelimited := true;
FFieldNum := StrToIntDef(Data,BLANK);
Assert(FFieldNum <> BLANK,'Invalid -f Switch');
end;
// Positional Key
if Sw = '-K' then
begin
FIsSwitches := true;
FIsPositional := true;
FStartPos := StrToIntDef(trim(copy(Data,1,pos(',',Data) - 1)),BLANK);
FEndPos := StrToIntDef(trim(copy(Data,pos(',',Data) + 1,1024)),BLANK);
Assert((FStartPos <> BLANK) and (FEndPos <> Blank),'Invalid -k Switch');
end;
end;
end;
// ====================================================
// INTERNAL CALL
// Resolve the Sort Key part of the string based on
// the Switches parameters
// ====================================================
function TSuperSort.GetKeyString(const Line : string) : string;
var
Key : string;
Numvar : double;
DCount, i, DPos : integer;
Tmp : string;
begin
// Default
Key := Line;
// Extract Key from switches -k takes precedence
if FIsPositional then
Key := copy(Key,FStartPos,FEndPos)
else
if FIsDelimited then
begin
DPos := 0;
DCount := 0;
for i := 1 to length(Key) do
begin
if Key[i] = FDelimiter then
inc(DCount);
if DCount = FFieldNum then
begin
if FFieldNum = 0 then
DPos := 1
else
DPos := i + 1;
break;
end;
end;
if DCount < FFieldNum then
// No such Field Number
Key := EMPTYSTR
else
begin
Tmp := copy(Key,DPos,4096);
DPos := pos(FDelimiter,Tmp);
if DPos = 0 then
Key := Tmp
else
Key := copy(Tmp,1,DPos - 1);
end;
end;
// Resolve Options
if FEvalNumeric then
begin
Key := trim(Key);
// Strip any commas
for i := length(Key) downto 1 do
if Key[i] = ',' then delete(Key,i,1);
try
Numvar := StrToFloat(Key);
except
Numvar := 0.0;
end;
Key := FormatFloat('############0.000000',Numvar);
// Leftpad num string
Key := StringOfChar('0',20 - length(Key)) + Key;
end;
// Ignores N/A for Numeric and DateTime
if not FEvalNumeric and not FEvalDateTime then
begin
if FIgnoreBlank then Key := trim(Key);
if FIgnoreCase then Key := UpperCase(Key);
end;
Result := Key;
end;
// ==============================================
// INTERNAL CALL
// Recursive STRING quick sort routine ASCENDING.
// ==============================================
procedure TSuperSort.QuickSortStrA(SL : TStrings);
procedure Sort(l,r : integer);
var
i, j : integer;
x, Tmp : string;
begin
i := l;
j := r;
x := GetKeyString(SL[(l + r) div 2]);
repeat
while GetKeyString(SL[i]) < x do
inc(i);
while x < GetKeyString(SL[j]) do
dec(j);
if i <= j then
begin
Tmp := SL[j];
SL[j] := SL[i];
SL[i] := Tmp;
inc(i);
dec(j);
end;
until i > j;
if l < j then
Sort(l,j);
if i < r then
Sort(i,r);
end;
begin
if SL.Count > 0 then
begin
SL.BeginUpdate;
Sort(0,SL.Count - 1);
SL.EndUpdate;
end;
end;
// ==============================================
// INTERNAL CALL
// Recursive STRING quick sort routine DECENDING
// ==============================================
procedure TSuperSort.QuickSortStrD(SL : TStrings);
procedure Sort(l,r : integer);
var
i, j : integer;
x, Tmp : string;
begin
i := l;
j := r;
x := GetKeyString(SL[(l + r) div 2]);
repeat
while GetKeyString(SL[i]) > x do
inc(i);
while x > GetKeyString(SL[j]) do
dec(j);
if i <= j then
begin
Tmp := SL[j];
SL[j] := SL[i];
SL[i] := Tmp;
inc(i);
dec(j);
end;
until i > j;
if l < j then
Sort(l,j);
if i < r then
Sort(i,r);
end;
begin
if SL.Count > 0 then
begin
SL.BeginUpdate;
Sort(0,SL.Count - 1);
SL.EndUpdate;
end;
end;
// ====================
// Sort a stringlist
// ====================
procedure TSuperSort.SortStrings(StringList : TStrings;
Switches : array of string; Options : TSuperSortOptionSet = []);
var
StartTime : TDateTime;
begin
StartTime := Now;
FDescending := (srtDescending in Options);
FIgnoreCase := (srtIgnoreCase in Options);
FIgnoreBlank := (srtIgnoreBlank in Options);
FEvalNumeric := (srtEvalNumeric in Options);
ResolveSwitches(Switches);
if FDescending then
QuickSortStrD(StringList)
else
QuickSortStrA(StringList);
FSortTime := Now - StartTime;
end;
end.
Recent
