Author: Mike Heydon
TStringList has a Sort method and a Sorted property. This feature is not available
in it's useful descendant TStrings. 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 algorythm utilizes the
QUICK SORT method.
Answer:
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 it just sorts the TStrings ascending
eg. 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 :
1
2 procedure SortStrings(StringList : TStrings; Switches : array of string;
3 Options : TSuperSortOptionSet = []);
4
5 Switches is a string array of -k,-d and -f settings. if it is set to empty array
6 [] then NO switches are active.
7
8 Options is an OPTIONAL set of
9 [srtDescending,srtIgnoreCase,srtIgnoreBlank,srtEvalNumeric]
10 The default is empty set []
11
12 //Properties :
13
14 SortTime : TDateTime;
15
16 // Returns the time taken for the sort for stats purposes.
17
18 //Usage Example :
19
20 uses SuperSort;
21
22 procedure TForm1.Test;
23 var
24 Srt: TSuperSort
25 begin
26 Srt := TSuperSort.Create;
27 Srt.SortStrings(Memo1.Lines, [], [srtIgnoreBlank]);
28 Label1.Caption := 'Time : ' + FormatDateTine('hh:nn:ss:zzz',Srt.SortTime);
29 Srt.Free;
30 end;
31
32 unit TSuperSort:
33
34 unit SuperSort;
35 interface
36 uses Classes, SysUtils;
37
38 // =============================================================================
39 // Class TSuperSort
40 // Mike Heydon Nov 2002
41 //
42 // Sort class that implements Unix style sorts including ..
43 //
44 // SWITCHES
45 // --------
46 // -k [StartPos,EndPos] - Keyfield to sort on. Start and End pos in string
47 // -d [Field Delimiter] - Delimter to use with -f switch. default = SPACE
48 // -f [FieldNumber] - Zero based field number delimeted by -d
49 //
50 // OPTIONS SET
51 // ============
52 // srtDescending - Sort descending
53 // srtIgnoreCase - Ignore case when sorting
54 // srtIgnoreBlank - Ignore leading blanks
55 // srtEvalNumeric - Treat sort items as NUMERIC
56 //
57 // =============================================================================
58
59 type
60 // Sort Options
61 TSuperSortOptions = (srtDescending, srtIgnoreCase,
62 srtIgnoreBlank, srtEvalNumeric);
63 TSuperSortOptionSet = set of TSuperSortOptions;
64
65 // ============
66 // TSuperSort
67 // ============
68 TSuperSort = class(TObject)
69 protected
70 function GetKeyString(const Line: string): string;
71 procedure QuickSortStrA(SL: TStrings);
72 procedure QuickSortStrD(SL: TStrings);
73 procedure ResolveSwitches(Switches: array of string);
74 private
75 FSortTime: TDateTime;
76 FIsSwitches,
77 FIsPositional,
78 FIsDelimited,
79 FDescending,
80 FIgnoreCase,
81 FIgnoreBlank,
82 FEvalDateTime,
83 FEvalNumeric: boolean;
84 FFieldNum,
85 FStartPos, FEndPos: integer;
86 FDelimiter: char;
87 public
88 procedure SortStrings(StringList: TStrings;
89 Switches: array of string;
90 Options: TSuperSortOptionSet = []);
91 property SortTime: TDateTime read FSortTime;
92 end;
93
94 // -----------------------------------------------------------------------------
95 implementation
96
97 const
98 BLANK = -1;
99 EMPTYSTR = '';
100
101 // ================================================
102 // INTERNAL CALL
103 // Resolve switches and set internal variables
104 // ================================================
105
106 procedure TSuperSort.ResolveSwitches(Switches: array of string);
107 var
108 i: integer;
109 Sw, Data: string;
110 begin
111 FStartPos := BLANK;
112 FEndPos := BLANK;
113 FFieldNum := BLANK;
114 FDelimiter := ' ';
115 FIsPositional := false;
116 FIsDelimited := false;
117
118 for i := Low(Switches) to High(Switches) do
119 begin
120 Sw := trim(Switches[i]);
121 Data := trim(copy(Sw, 3, 1024));
122 Sw := UpperCase(copy(Sw, 1, 2));
123
124 // Delimiter
125 if Sw = '-D' then
126 begin
127 if length(Data) > 0 then
128 FDelimiter := Data[1];
129 end;
130
131 // Field Number
132 if Sw = '-F' then
133 begin
134 FIsSwitches := true;
135 FIsDelimited := true;
136 FFieldNum := StrToIntDef(Data, BLANK);
137 Assert(FFieldNum <> BLANK, 'Invalid -f Switch');
138 end;
139
140 // Positional Key
141 if Sw = '-K' then
142 begin
143 FIsSwitches := true;
144 FIsPositional := true;
145 FStartPos := StrToIntDef(trim(copy(Data, 1, pos(',', Data) - 1)), BLANK);
146 FEndPos := StrToIntDef(trim(copy(Data, pos(',', Data) + 1, 1024)), BLANK);
147 Assert((FStartPos <> BLANK) and (FEndPos <> Blank), 'Invalid -k Switch');
148 end;
149
150 end;
151 end;
152
153 // ====================================================
154 // INTERNAL CALL
155 // Resolve the Sort Key part of the string based on
156 // the Switches parameters
157 // ====================================================
158
159 function TSuperSort.GetKeyString(const Line: string): string;
160 var
161 Key: string;
162 Numvar: double;
163 DCount, i, DPos: integer;
164 Tmp: string;
165 begin
166 // Default
167 Key := Line;
168 // Extract Key from switches -k takes precedence
169 if FIsPositional then
170 Key := copy(Key, FStartPos, FEndPos)
171 else if FIsDelimited then
172 begin
173 DPos := 0;
174 DCount := 0;
175 for i := 1 to length(Key) do
176 begin
177 if Key[i] = FDelimiter then
178 inc(DCount);
179 if DCount = FFieldNum then
180 begin
181 if FFieldNum = 0 then
182 DPos := 1
183 else
184 DPos := i + 1;
185 break;
186 end;
187 end;
188
189 if DCount < FFieldNum then
190 // No such Field Number
191 Key := EMPTYSTR
192 else
193 begin
194 Tmp := copy(Key, DPos, 4096);
195 DPos := pos(FDelimiter, Tmp);
196 if DPos = 0 then
197 Key := Tmp
198 else
199 Key := copy(Tmp, 1, DPos - 1);
200 end;
201 end;
202
203 // Resolve Options
204 if FEvalNumeric then
205 begin
206 Key := trim(Key);
207 // Strip any commas
208 for i := length(Key) downto 1 do
209 if Key[i] = ',' then
210 delete(Key, i, 1);
211 try
212 Numvar := StrToFloat(Key);
213 except
214 Numvar := 0.0;
215 end;
216 Key := FormatFloat('############0.000000', Numvar);
217 // Leftpad num string
218 Key := StringOfChar('0', 20 - length(Key)) + Key;
219 end;
220
221 // Ignores N/A for Numeric and DateTime
222 if not FEvalNumeric and not FEvalDateTime then
223 begin
224 if FIgnoreBlank then
225 Key := trim(Key);
226 if FIgnoreCase then
227 Key := UpperCase(Key);
228 end;
229
230 Result := Key;
231 end;
232
233 // ==============================================
234 // INTERNAL CALL
235 // Recursive STRING quick sort routine ASCENDING.
236 // ==============================================
237
238 procedure TSuperSort.QuickSortStrA(SL: TStrings);
239
240 procedure Sort(l, r: integer);
241 var
242 i, j: integer;
243 x, Tmp: string;
244 begin
245 i := l;
246 j := r;
247 x := GetKeyString(SL[(l + r) div 2]);
248
249 repeat
250 while GetKeyString(SL[i]) < x do
251 inc(i);
252 while x < GetKeyString(SL[j]) do
253 dec(j);
254 if i <= j then
255 begin
256 Tmp := SL[j];
257 SL[j] := SL[i];
258 SL[i] := Tmp;
259 inc(i);
260 dec(j);
261 end;
262 until i > j;
263
264 if l < j then
265 Sort(l, j);
266 if i < r then
267 Sort(i, r);
268 end;
269
270 begin
271 if SL.Count > 0 then
272 begin
273 SL.BeginUpdate;
274 Sort(0, SL.Count - 1);
275 SL.EndUpdate;
276 end;
277 end;
278
279 // ==============================================
280 // INTERNAL CALL
281 // Recursive STRING quick sort routine DECENDING
282 // ==============================================
283
284 procedure TSuperSort.QuickSortStrD(SL: TStrings);
285 procedure Sort(l, r: integer);
286 var
287 i, j: integer;
288 x, Tmp: string;
289 begin
290 i := l;
291 j := r;
292 x := GetKeyString(SL[(l + r) div 2]);
293
294 repeat
295 while GetKeyString(SL[i]) > x do
296 inc(i);
297 while x > GetKeyString(SL[j]) do
298 dec(j);
299 if i <= j then
300 begin
301 Tmp := SL[j];
302 SL[j] := SL[i];
303 SL[i] := Tmp;
304 inc(i);
305 dec(j);
306 end;
307 until i > j;
308
309 if l < j then
310 Sort(l, j);
311 if i < r then
312 Sort(i, r);
313 end;
314
315 begin
316 if SL.Count > 0 then
317 begin
318 SL.BeginUpdate;
319 Sort(0, SL.Count - 1);
320 SL.EndUpdate;
321 end;
322 end;
323
324 // ====================
325 // Sort a stringlist
326 // ====================
327
328 procedure TSuperSort.SortStrings(StringList: TStrings;
329 Switches: array of string;
330 Options: TSuperSortOptionSet = []);
331 var
332 StartTime: TDateTime;
333 begin
334 StartTime := Now;
335 FDescending := (srtDescending in Options);
336 FIgnoreCase := (srtIgnoreCase in Options);
337 FIgnoreBlank := (srtIgnoreBlank in Options);
338 FEvalNumeric := (srtEvalNumeric in Options);
339 ResolveSwitches(Switches);
340
341 if FDescending then
342 QuickSortStrD(StringList)
343 else
344 QuickSortStrA(StringList);
345
346 FSortTime := Now - StartTime;
347 end;
348
349 end.
|
