examples/Delphi/TxtSortU.pas

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

unit TxtSortU;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons,

  StConst, StBase, StColl, StSort;

const
  MaxStrLen = 1024;

type
  SortException = class(Exception);
  LineBuf = array[0..MaxStrLen-1] of char;

  TSTDlg = class(TForm)
    GroupBox1: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    InFile: TEdit;
    OutFile: TEdit;
    GroupBox2: TGroupBox;
    RevOrder: TCheckBox;
    IgnoreCase: TCheckBox;
    GroupBox3: TGroupBox;
    Label3: TLabel;
    Label4: TLabel;
    StartPos: TEdit;
    KeyLen: TEdit;
    OkBtn: TBitBtn;
    CloseBtn: TBitBtn;
    GroupBox4: TGroupBox;
    Status: TLabel;
    AbortBtn: TBitBtn;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    InputBtn: TSpeedButton;
    OutputBtn: TSpeedButton;
    procedure OkBtnClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure CloseBtnClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure AbortBtnClick(Sender: TObject);
    procedure InputBtnClick(Sender: TObject);
    procedure OutputBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    DoAbort,
    InSort,
    DoRev,
    Ignore  : Boolean;

    SPos,
    KeyL    : Integer;

    LC      : LongInt;

    InF,
    OutF    : TextFile;

    MySort  : TStSorter;

    function ValidateEntryFields : Boolean;
    procedure CleanUp;
  end;


var
  STDlg: TSTDlg;

implementation

{$R *.DFM}

procedure DelNodeData(Data : pointer); far;
 {-procedure to delete data pointer in each node}
begin
  Dispose(Data);
end;


function TFSorter(const S1, S2) : Integer; far;
var
  PX, PY : LineBuf;
begin
  if STDlg.DoRev then begin
    StrCopy(PX, LineBuf(S2));
    StrCopy(PY, LineBuf(S1));
  end else begin
    StrCopy(PX, LineBuf(S1));
    StrCopy(PY, LineBuf(S2));
  end;


  if STDlg.Ignore then begin
    if (StrLIComp(@PX[STDlg.SPos-1], @PY[STDlg.SPos-1], STDlg.KeyL) < 0) then
      Result := -1
    else
      Result := 0;
  end else begin
    if (StrLComp(@PX[STDlg.SPos-1], @PY[STDlg.SPos-1], STDlg.KeyL) < 0) then
      Result := -1
    else
      Result := 0;
  end;
end;

procedure TSTDlg.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if MySort <> nil then
    MySort.Free;
end;

procedure TSTDlg.CloseBtnClick(Sender: TObject);
begin
  if InSort then Exit;
  Close;
end;

function TSTDlg.ValidateEntryFields : Boolean;
var
  Code  : Integer;

begin
  Result := False;

  if NOT FileExists(InFile.Text) then
  begin
    ShowMessage('Input file does not exist');
    Exit;
  end;

  if FileExists(OutFile.Text) then
  begin
    if MessageDlg('Output file exists' + #13 + 'Continue?',
                  mtConfirmation,[mbYes,mbNo],0) = mrNo then
      Exit;
  end;

  if (CompareText(InFile.Text,OutFile.Text) = 0) then
  begin
    ShowMessage('Input and Output file can not be the same');
    Exit;
  end;

  val(StartPos.Text,SPos,Code);
  if (Code <> 0) then
  begin
    ShowMessage('Invalid Start entry');
    Exit;
  end;
  if (SPos < 1) OR (SPos >= MaxStrLen) then
  begin
    ShowMessage('Start out of range');
    Exit;
  end;

  val(KeyLen.Text,KeyL,Code);
  if (Code <> 0) then
  begin
    ShowMessage('Invalid Length entry');
    Exit;
  end;
  if (KeyL < 1) OR (KeyL > MaxStrLen-SPos) then
  begin
    ShowMessage('Key Length out of range');
    Exit;
  end;

  DoRev  := RevOrder.Checked;
  Ignore := IgnoreCase.Checked;

  Result := True;
end;


procedure TSTDlg.CleanUp;
begin
  CloseFile(InF);
  CloseFile(OutF);
  InSort := False;
  DoAbort := True;

  MySort.Free;
  MySort := nil;
end;

procedure TSTDlg.OkBtnClick(Sender: TObject);
var
  PS : LineBuf;
begin
  if NOT ValidateEntryFields then
    Exit;

  AssignFile(InF,InFile.Text);
  Reset(InF);
  AssignFile(OutF,OutFile.Text);
  ReWrite(OutF);

  if MySort <> nil then begin
    MySort.Free;
    MySort := nil;
  end;

  MySort := TStSorter.Create(500000, SizeOf(LineBuf));
  MySort.Compare := TFSorter;

  DoAbort := False;
  InSort := True;
  LC := 0;

  while NOT EOF(InF) do begin
    FillChar(PS, SizeOf(PS), #0);
    Readln(InF, PS);
    Inc(LC);
    Status.Caption := 'Reading/Sorting line: ' + IntToStr(LC);
    MySort.Put(PS);

    if (LC mod 100) = 0 then begin
      Application.ProcessMessages;
      if DoAbort then begin
        CleanUp;
        Status.Caption := 'Sort Aborted';
        Exit;
      end;
    end;
  end;

  Status.Caption := 'Processing';
  Status.Update;
  Application.ProcessMessages;

  if NOT DoAbort then begin
    LC := 0;
    while MySort.Get(PS) do begin
      Inc(LC);
      Status.Caption := 'Writing line: ' + IntToStr(LC);
      Writeln(OutF, PS);

      if (LC mod 100) = 0 then begin
        Application.ProcessMessages;
        if DoAbort then begin
          CleanUp;
          Status.Caption := 'Sort Aborted';
          Exit;
        end;
      end;
    end;
  end;

  if NOT DoAbort then begin
    CleanUp;
    Status.Caption := 'Done';
  end;
end;


procedure TSTDlg.FormActivate(Sender: TObject);
begin
  IgnoreCase.Checked := True;
  RevOrder.Checked := False;
  InFile.Text := '';
  OutFile.Text := '';
  StartPos.Text := '1';
  KeyLen.Text := '20';
  Status.Caption := 'Idle';
end;

procedure TSTDlg.AbortBtnClick(Sender: TObject);
begin
  DoAbort := True;
end;

procedure TSTDlg.InputBtnClick(Sender: TObject);
begin
  if OpenDialog1.Execute then
    InFile.Text := OpenDialog1.FileName;
end;

procedure TSTDlg.OutputBtnClick(Sender: TObject);
begin
  if SaveDialog1.Execute then
    OutFile.Text := SaveDialog1.FileName;
end;

end.
1	(* *** BEGIN LICENSE BLOCK ***
2	* Version: MPL 1.1
3	*
4	* The contents of this file are subject to the Mozilla Public License Version
5	* 1.1 (the "License"); you may not use this file except in compliance with
6	* the License. You may obtain a copy of the License at
7	* http://www.mozilla.org/MPL/
8	*
9	* Software distributed under the License is distributed on an "AS IS" basis,
10	* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
11	* for the specific language governing rights and limitations under the
12	* License.
13	*
14	* The Original Code is TurboPower SysTools
15	*
16	* The Initial Developer of the Original Code is
17	* TurboPower Software
18	*
19	* Portions created by the Initial Developer are Copyright (C) 1996-2002
20	* the Initial Developer. All Rights Reserved.
21	*
22	* Contributor(s):
23	*
24	* *** END LICENSE BLOCK *** *)
25
26	unit TxtSortU;
27
28	interface
29
30	uses
31	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
32	StdCtrls, Buttons,
33
34	StConst, StBase, StColl, StSort;
35
36	const
37	MaxStrLen = 1024;
38
39	type
40	SortException = class(Exception);
41	LineBuf = array[0..MaxStrLen-1] of char;
42
43	TSTDlg = class(TForm)
44	GroupBox1: TGroupBox;
45	Label1: TLabel;
46	Label2: TLabel;
47	InFile: TEdit;
48	OutFile: TEdit;
49	GroupBox2: TGroupBox;
50	RevOrder: TCheckBox;
51	IgnoreCase: TCheckBox;
52	GroupBox3: TGroupBox;
53	Label3: TLabel;
54	Label4: TLabel;
55	StartPos: TEdit;
56	KeyLen: TEdit;
57	OkBtn: TBitBtn;
58	CloseBtn: TBitBtn;
59	GroupBox4: TGroupBox;
60	Status: TLabel;
61	AbortBtn: TBitBtn;
62	OpenDialog1: TOpenDialog;
63	SaveDialog1: TSaveDialog;
64	InputBtn: TSpeedButton;
65	OutputBtn: TSpeedButton;
66	procedure OkBtnClick(Sender: TObject);
67	procedure FormClose(Sender: TObject; var Action: TCloseAction);
68	procedure CloseBtnClick(Sender: TObject);
69	procedure FormActivate(Sender: TObject);
70	procedure AbortBtnClick(Sender: TObject);
71	procedure InputBtnClick(Sender: TObject);
72	procedure OutputBtnClick(Sender: TObject);
73	private
74	{ Private declarations }
75	public
76	{ Public declarations }
77	DoAbort,
78	InSort,
79	DoRev,
80	Ignore : Boolean;
81
82	SPos,
83	KeyL : Integer;
84
85	LC : LongInt;
86
87	InF,
88	OutF : TextFile;
89
90	MySort : TStSorter;
91
92	function ValidateEntryFields : Boolean;
93	procedure CleanUp;
94	end;
95
96
97	var
98	STDlg: TSTDlg;
99
100	implementation
101
102	{$R *.DFM}
103
104	procedure DelNodeData(Data : pointer); far;
105	{-procedure to delete data pointer in each node}
106	begin
107	Dispose(Data);
108	end;
109
110
111	function TFSorter(const S1, S2) : Integer; far;
112	var
113	PX, PY : LineBuf;
114	begin
115	if STDlg.DoRev then begin
116	StrCopy(PX, LineBuf(S2));
117	StrCopy(PY, LineBuf(S1));
118	end else begin
119	StrCopy(PX, LineBuf(S1));
120	StrCopy(PY, LineBuf(S2));
121	end;
122
123
124
125	if STDlg.Ignore then begin
126	if (StrLIComp(@PX[STDlg.SPos-1], @PY[STDlg.SPos-1], STDlg.KeyL) < 0) then
127	Result := -1
128	else
129	Result := 0;
130	end else begin
131	if (StrLComp(@PX[STDlg.SPos-1], @PY[STDlg.SPos-1], STDlg.KeyL) < 0) then
132	Result := -1
133	else
134	Result := 0;
135	end;
136	end;
137
138	procedure TSTDlg.FormClose(Sender: TObject; var Action: TCloseAction);
139	begin
140	if MySort <> nil then
141	MySort.Free;
142	end;
143
144	procedure TSTDlg.CloseBtnClick(Sender: TObject);
145	begin
146	if InSort then Exit;
147	Close;
148	end;
149
150	function TSTDlg.ValidateEntryFields : Boolean;
151	var
152	Code : Integer;
153
154	begin
155	Result := False;
156
157	if NOT FileExists(InFile.Text) then
158	begin
159	ShowMessage('Input file does not exist');
160	Exit;
161	end;
162
163	if FileExists(OutFile.Text) then
164	begin
165	if MessageDlg('Output file exists' + #13 + 'Continue?',
166	mtConfirmation,[mbYes,mbNo],0) = mrNo then
167	Exit;
168	end;
169
170	if (CompareText(InFile.Text,OutFile.Text) = 0) then
171	begin
172	ShowMessage('Input and Output file can not be the same');
173	Exit;
174	end;
175
176	val(StartPos.Text,SPos,Code);
177	if (Code <> 0) then
178	begin
179	ShowMessage('Invalid Start entry');
180	Exit;
181	end;
182	if (SPos < 1) OR (SPos >= MaxStrLen) then
183	begin
184	ShowMessage('Start out of range');
185	Exit;
186	end;
187
188	val(KeyLen.Text,KeyL,Code);
189	if (Code <> 0) then
190	begin
191	ShowMessage('Invalid Length entry');
192	Exit;
193	end;
194	if (KeyL < 1) OR (KeyL > MaxStrLen-SPos) then
195	begin
196	ShowMessage('Key Length out of range');
197	Exit;
198	end;
199
200	DoRev := RevOrder.Checked;
201	Ignore := IgnoreCase.Checked;
202
203	Result := True;
204	end;
205
206
207	procedure TSTDlg.CleanUp;
208	begin
209	CloseFile(InF);
210	CloseFile(OutF);
211	InSort := False;
212	DoAbort := True;
213
214	MySort.Free;
215	MySort := nil;
216	end;
217
218	procedure TSTDlg.OkBtnClick(Sender: TObject);
219	var
220	PS : LineBuf;
221	begin
222	if NOT ValidateEntryFields then
223	Exit;
224
225	AssignFile(InF,InFile.Text);
226	Reset(InF);
227	AssignFile(OutF,OutFile.Text);
228	ReWrite(OutF);
229
230	if MySort <> nil then begin
231	MySort.Free;
232	MySort := nil;
233	end;
234
235	MySort := TStSorter.Create(500000, SizeOf(LineBuf));
236	MySort.Compare := TFSorter;
237
238	DoAbort := False;
239	InSort := True;
240	LC := 0;
241
242	while NOT EOF(InF) do begin
243	FillChar(PS, SizeOf(PS), #0);
244	Readln(InF, PS);
245	Inc(LC);
246	Status.Caption := 'Reading/Sorting line: ' + IntToStr(LC);
247	MySort.Put(PS);
248
249	if (LC mod 100) = 0 then begin
250	Application.ProcessMessages;
251	if DoAbort then begin
252	CleanUp;
253	Status.Caption := 'Sort Aborted';
254	Exit;
255	end;
256	end;
257	end;
258
259	Status.Caption := 'Processing';
260	Status.Update;
261	Application.ProcessMessages;
262
263	if NOT DoAbort then begin
264	LC := 0;
265	while MySort.Get(PS) do begin
266	Inc(LC);
267	Status.Caption := 'Writing line: ' + IntToStr(LC);
268	Writeln(OutF, PS);
269
270	if (LC mod 100) = 0 then begin
271	Application.ProcessMessages;
272	if DoAbort then begin
273	CleanUp;
274	Status.Caption := 'Sort Aborted';
275	Exit;
276	end;
277	end;
278	end;
279	end;
280
281	if NOT DoAbort then begin
282	CleanUp;
283	Status.Caption := 'Done';
284	end;
285	end;
286
287
288	procedure TSTDlg.FormActivate(Sender: TObject);
289	begin
290	IgnoreCase.Checked := True;
291	RevOrder.Checked := False;
292	InFile.Text := '';
293	OutFile.Text := '';
294	StartPos.Text := '1';
295	KeyLen.Text := '20';
296	Status.Caption := 'Idle';
297	end;
298
299	procedure TSTDlg.AbortBtnClick(Sender: TObject);
300	begin
301	DoAbort := True;
302	end;
303
304	procedure TSTDlg.InputBtnClick(Sender: TObject);
305	begin
306	if OpenDialog1.Execute then
307	InFile.Text := OpenDialog1.FileName;
308	end;
309
310	procedure TSTDlg.OutputBtnClick(Sender: TObject);
311	begin
312	if SaveDialog1.Execute then
313	OutFile.Text := SaveDialog1.FileName;
314	end;
315
316	end.