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	torben	2671	(* *** 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.