examples/Delphi/Ex1DArrU.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 Ex1DArrU;

interface

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

  StConst, StUtils, StBase, StLArr;

type
  ARecord = record
    X, Y   : LongInt;
    Mag    : Double;
    Name1  : string[10];
    Name2  : string[10];
  end;

type
  TSTDlg = class(TForm)
    CreateBtn: TButton;
    ElemNum: TEdit;
    ClearBtn: TButton;
    FillBtn: TButton;
    PutBtn: TButton;
    GetBtn: TButton;
    SortBtn: TButton;
    LB1: TListBox;
    Label4: TLabel;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    Edit5: TEdit;
    LoadBtn: TButton;
    SaveBtn: TButton;
    OD1: TOpenDialog;
    SD1: TSaveDialog;

    procedure FormClose(Sender: TObject; var Action: TCloseAction);

    procedure CreateBtnClick(Sender: TObject);
    procedure ClearBtnClick(Sender: TObject);
    procedure FillBtnClick(Sender: TObject);
    procedure PutBtnClick(Sender: TObject);
    procedure GetBtnClick(Sender: TObject);
    procedure SortBtnClick(Sender: TObject);
    procedure LB1DblClick(Sender: TObject);
    procedure LoadBtnClick(Sender: TObject);
    procedure SaveBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    MyLArray : TStLArray;
    ARec     : ARecord;

    procedure SetBusy(B : Boolean);
    procedure FillControls;
    procedure FillListBox;
    function CheckControls(var AR : ARecord) : Boolean;
    procedure UpdateButtons(AOK : Boolean);
  end;

var
  STDlg: TSTDlg;

implementation

{$R *.DFM}


procedure TSTDlg.FormCreate(Sender: TObject);
begin
  RegisterClass(TStLArray);
  UpdateButtons(False);
end;

procedure TSTDlg.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  MyLArray.Free;
end;

procedure TSTDlg.SetBusy(B : Boolean);
begin
  if B then
    Screen.Cursor := crHourGlass
  else
    Screen.Cursor := crDefault;
end;


function MyArraySort(const El1, El2) : Integer; far;
var
  R1, R2  : ARecord;
begin
  R1 := ARecord(El1);
  R2 := ARecord(El2);

  Result := (R1.X-R2.X);
  if Result = 0 then
    Result := (R1.Y-R2.Y);
  if Result = 0 then
    Result := Trunc(R1.Mag-R2.Mag);
  if Result = 0 then
    Result := CompareText(R1.Name1,R2.Name1);
  if Result = 0 then
    Result := CompareText(R1.Name2,R2.Name2);
end;

procedure TSTDlg.FillControls;
begin
  with ARec do
  begin
    Edit1.Text := Name1;
    Edit2.Text := Name2;
    Edit3.Text := IntToStr(X);
    Edit4.Text := IntToStr(Y);
    Edit5.Text := FloatToStr(Mag);
  end;
end;

procedure TSTDlg.FillListBox;
var
  step : integer;
begin
  SetBusy(True);
  LB1.Clear;
  LB1.Perform(WM_SETREDRAW,0,0);
  for step := 0 to MyLArray.Count-1 do
  begin
    MyLArray.Get(step,ARec);
    LB1.Items.Add(IntToStr(ARec.X) + ', ' + IntToStr(ARec.Y));
  end;
  LB1.Perform(WM_SETREDRAW,1,0);
  LB1.Update;
  MyLArray.Get(0,ARec);
  SetBusy(False);
end;

function TSTDlg.CheckControls(var AR : ARecord) : Boolean;
var
  C,
  IV : Integer;
  IR : Single;

begin
  Result := False;

  if (Edit1.Text = '') OR
     (Edit2.Text = '') OR
     (Edit3.Text = '') OR
     (Edit4.Text = '') OR
     (Edit5.Text = '') then
    Exit;

  AR.Name1 := Edit1.Text;
  AR.Name2 := Edit2.Text;

  Val(Edit3.Text,IV,C);
  if (C<>0) then
    Exit
  else
    AR.X := IV;

  Val(Edit4.Text,IV,C);
  if (C<>0) then
    Exit
  else
    AR.Y := IV;

  Val(Edit5.Text,IR,C);
  if (C<>0) then
    Exit
  else
    AR.Mag := IR;
  Result := True;
end;

procedure TSTDlg.UpdateButtons(AOK : Boolean);
begin
  ClearBtn.Enabled := AOK;
  FillBtn.Enabled  := AOK;
  GetBtn.Enabled   := AOK;
  PutBtn.Enabled   := AOK;
  SortBtn.Enabled  := AOK;
  SaveBtn.Enabled  := AOK;
end;

procedure TSTDlg.CreateBtnClick(Sender: TObject);
var
  step,
  I, J,
  Value : LongInt;
begin
  LB1.Clear;
  SetBusy(True);

  if Assigned(MyLArray) then
    MyLArray.Free;

  UpdateButtons(False);
  MyLArray := TStLArray.Create(5000, sizeof(ARec));

  MyLArray.ElementsStorable := True;
  MyLArray.Clear;

  Randomize;
  LB1.Perform(WM_SETREDRAW,0,0);
  Value := MyLArray.Count;

  for step := 0 to Value-1 do
  begin
    with ARec do begin
      Name1 := '';
      Name2 := '';
      for I := 1 to 10 do begin
        J := Random(26) + Ord('A');
        Name1 := Name1+ Chr(J);
        J := Random(26) + Ord('A');
        Name2 := Name2 + Chr(J);
      end;

      X := Trunc(Random(1000));
      Y := Trunc(Random(1000));
      Mag := Sqrt(Random(25000));

      MyLArray.Put(step,ARec);

      LB1.Items.Add(IntToStr(ARec.X) + ', ' + IntToStr(ARec.Y));
    end;
  end;
  LB1.Perform(WM_SETREDRAW,1,0);
  LB1.Update;

  ElemNum.Text := '0';
  MyLArray.Get(0,ARec);
  FillControls;
  UpdateButtons(True);
  SetBusy(False);
end;


procedure TSTDlg.ClearBtnClick(Sender: TObject);
begin
  MyLArray.Clear;
  LB1.Clear;

  ElemNum.Text := '0';
  MyLArray.Get(0,ARec);
  FillControls;
end;

procedure TSTDlg.FillBtnClick(Sender: TObject);
begin
  if NOT CheckControls(ARec) then
  begin
    ShowMessage('One or more invalid entries');
    Exit;
  end;

  MyLArray.Fill(ARec);

  FillListBox;
  ElemNum.Text := '0';
  MyLArray.Get(0,ARec);
  FillControls;
end;

procedure TSTDlg.PutBtnClick(Sender: TObject);
var
  E  : LongInt;
begin
  if (ElemNum.Text = '') then
    ElemNum.Text := '0';

  if NOT CheckControls(ARec) then
  begin
    ShowMessage('One or more invalid entries');
    Exit;
  end;

  E := StrToInt(ElemNum.Text);
  MyLArray.Put(E,ARec);

  LB1.Items[E] := IntToStr(ARec.X) + ', ' + IntToStr(ARec.Y);

  MyLArray.Get(E,ARec);
  FillControls;
end;


procedure TSTDlg.GetBtnClick(Sender: TObject);
var
  E : LongInt;
begin
  if (ElemNum.Text = '') then
    ElemNum.Text := '0';

  E := StrToInt(ElemNum.Text);
  MyLArray.Get(E,ARec);

  FillControls;
end;

procedure TSTDlg.SortBtnClick(Sender: TObject);
begin
  SetBusy(True);
  MyLArray.Sort(MyArraySort);
  SetBusy(False);

  FillListBox;
  FillControls;
  SetBusy(False);
end;

procedure TSTDlg.LB1DblClick(Sender: TObject);
begin
  MyLArray.Get(LB1.ItemIndex,ARec);
  ElemNum.Text := IntToStr(LB1.ItemIndex);
  FillControls;
end;

procedure TSTDlg.LoadBtnClick(Sender: TObject);
begin
  if (OD1.Execute) then
  begin
    if (NOT Assigned(MyLArray)) then
    begin
      UpdateButtons(False);
      MyLArray := TStLArray.Create(5000, sizeof(ARec));
      MyLArray.ElementsStorable := True;
    end;

    MyLArray.Clear;
    MyLArray.LoadFromFile(OD1.FileName);

    FillListBox;
    FillControls;
    UpdateButtons(True);
  end;
end;

procedure TSTDlg.SaveBtnClick(Sender: TObject);
begin
  if (SD1.Execute) then
    MyLArray.StoreToFile(SD1.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 Ex1DArrU;
27
28	interface
29
30	uses
31	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
32	StdCtrls, Buttons, ExtCtrls,
33
34	StConst, StUtils, StBase, StLArr;
35
36	type
37	ARecord = record
38	X, Y : LongInt;
39	Mag : Double;
40	Name1 : string[10];
41	Name2 : string[10];
42	end;
43
44	type
45	TSTDlg = class(TForm)
46	CreateBtn: TButton;
47	ElemNum: TEdit;
48	ClearBtn: TButton;
49	FillBtn: TButton;
50	PutBtn: TButton;
51	GetBtn: TButton;
52	SortBtn: TButton;
53	LB1: TListBox;
54	Label4: TLabel;
55	Label1: TLabel;
56	Label2: TLabel;
57	Label3: TLabel;
58	Label5: TLabel;
59	Label6: TLabel;
60	Edit1: TEdit;
61	Edit2: TEdit;
62	Edit3: TEdit;
63	Edit4: TEdit;
64	Edit5: TEdit;
65	LoadBtn: TButton;
66	SaveBtn: TButton;
67	OD1: TOpenDialog;
68	SD1: TSaveDialog;
69
70	procedure FormClose(Sender: TObject; var Action: TCloseAction);
71
72	procedure CreateBtnClick(Sender: TObject);
73	procedure ClearBtnClick(Sender: TObject);
74	procedure FillBtnClick(Sender: TObject);
75	procedure PutBtnClick(Sender: TObject);
76	procedure GetBtnClick(Sender: TObject);
77	procedure SortBtnClick(Sender: TObject);
78	procedure LB1DblClick(Sender: TObject);
79	procedure LoadBtnClick(Sender: TObject);
80	procedure SaveBtnClick(Sender: TObject);
81	procedure FormCreate(Sender: TObject);
82	private
83	{ Private declarations }
84	public
85	{ Public declarations }
86	MyLArray : TStLArray;
87	ARec : ARecord;
88
89	procedure SetBusy(B : Boolean);
90	procedure FillControls;
91	procedure FillListBox;
92	function CheckControls(var AR : ARecord) : Boolean;
93	procedure UpdateButtons(AOK : Boolean);
94	end;
95
96	var
97	STDlg: TSTDlg;
98
99	implementation
100
101	{$R *.DFM}
102
103
104	procedure TSTDlg.FormCreate(Sender: TObject);
105	begin
106	RegisterClass(TStLArray);
107	UpdateButtons(False);
108	end;
109
110	procedure TSTDlg.FormClose(Sender: TObject;
111	var Action: TCloseAction);
112	begin
113	MyLArray.Free;
114	end;
115
116	procedure TSTDlg.SetBusy(B : Boolean);
117	begin
118	if B then
119	Screen.Cursor := crHourGlass
120	else
121	Screen.Cursor := crDefault;
122	end;
123
124
125	function MyArraySort(const El1, El2) : Integer; far;
126	var
127	R1, R2 : ARecord;
128	begin
129	R1 := ARecord(El1);
130	R2 := ARecord(El2);
131
132	Result := (R1.X-R2.X);
133	if Result = 0 then
134	Result := (R1.Y-R2.Y);
135	if Result = 0 then
136	Result := Trunc(R1.Mag-R2.Mag);
137	if Result = 0 then
138	Result := CompareText(R1.Name1,R2.Name1);
139	if Result = 0 then
140	Result := CompareText(R1.Name2,R2.Name2);
141	end;
142
143	procedure TSTDlg.FillControls;
144	begin
145	with ARec do
146	begin
147	Edit1.Text := Name1;
148	Edit2.Text := Name2;
149	Edit3.Text := IntToStr(X);
150	Edit4.Text := IntToStr(Y);
151	Edit5.Text := FloatToStr(Mag);
152	end;
153	end;
154
155	procedure TSTDlg.FillListBox;
156	var
157	step : integer;
158	begin
159	SetBusy(True);
160	LB1.Clear;
161	LB1.Perform(WM_SETREDRAW,0,0);
162	for step := 0 to MyLArray.Count-1 do
163	begin
164	MyLArray.Get(step,ARec);
165	LB1.Items.Add(IntToStr(ARec.X) + ', ' + IntToStr(ARec.Y));
166	end;
167	LB1.Perform(WM_SETREDRAW,1,0);
168	LB1.Update;
169	MyLArray.Get(0,ARec);
170	SetBusy(False);
171	end;
172
173	function TSTDlg.CheckControls(var AR : ARecord) : Boolean;
174	var
175	C,
176	IV : Integer;
177	IR : Single;
178
179	begin
180	Result := False;
181
182	if (Edit1.Text = '') OR
183	(Edit2.Text = '') OR
184	(Edit3.Text = '') OR
185	(Edit4.Text = '') OR
186	(Edit5.Text = '') then
187	Exit;
188
189	AR.Name1 := Edit1.Text;
190	AR.Name2 := Edit2.Text;
191
192	Val(Edit3.Text,IV,C);
193	if (C<>0) then
194	Exit
195	else
196	AR.X := IV;
197
198	Val(Edit4.Text,IV,C);
199	if (C<>0) then
200	Exit
201	else
202	AR.Y := IV;
203
204	Val(Edit5.Text,IR,C);
205	if (C<>0) then
206	Exit
207	else
208	AR.Mag := IR;
209	Result := True;
210	end;
211
212	procedure TSTDlg.UpdateButtons(AOK : Boolean);
213	begin
214	ClearBtn.Enabled := AOK;
215	FillBtn.Enabled := AOK;
216	GetBtn.Enabled := AOK;
217	PutBtn.Enabled := AOK;
218	SortBtn.Enabled := AOK;
219	SaveBtn.Enabled := AOK;
220	end;
221
222	procedure TSTDlg.CreateBtnClick(Sender: TObject);
223	var
224	step,
225	I, J,
226	Value : LongInt;
227	begin
228	LB1.Clear;
229	SetBusy(True);
230
231	if Assigned(MyLArray) then
232	MyLArray.Free;
233
234	UpdateButtons(False);
235	MyLArray := TStLArray.Create(5000, sizeof(ARec));
236
237	MyLArray.ElementsStorable := True;
238	MyLArray.Clear;
239
240	Randomize;
241	LB1.Perform(WM_SETREDRAW,0,0);
242	Value := MyLArray.Count;
243
244	for step := 0 to Value-1 do
245	begin
246	with ARec do begin
247	Name1 := '';
248	Name2 := '';
249	for I := 1 to 10 do begin
250	J := Random(26) + Ord('A');
251	Name1 := Name1+ Chr(J);
252	J := Random(26) + Ord('A');
253	Name2 := Name2 + Chr(J);
254	end;
255
256	X := Trunc(Random(1000));
257	Y := Trunc(Random(1000));
258	Mag := Sqrt(Random(25000));
259
260	MyLArray.Put(step,ARec);
261
262	LB1.Items.Add(IntToStr(ARec.X) + ', ' + IntToStr(ARec.Y));
263	end;
264	end;
265	LB1.Perform(WM_SETREDRAW,1,0);
266	LB1.Update;
267
268	ElemNum.Text := '0';
269	MyLArray.Get(0,ARec);
270	FillControls;
271	UpdateButtons(True);
272	SetBusy(False);
273	end;
274
275
276	procedure TSTDlg.ClearBtnClick(Sender: TObject);
277	begin
278	MyLArray.Clear;
279	LB1.Clear;
280
281	ElemNum.Text := '0';
282	MyLArray.Get(0,ARec);
283	FillControls;
284	end;
285
286	procedure TSTDlg.FillBtnClick(Sender: TObject);
287	begin
288	if NOT CheckControls(ARec) then
289	begin
290	ShowMessage('One or more invalid entries');
291	Exit;
292	end;
293
294	MyLArray.Fill(ARec);
295
296	FillListBox;
297	ElemNum.Text := '0';
298	MyLArray.Get(0,ARec);
299	FillControls;
300	end;
301
302	procedure TSTDlg.PutBtnClick(Sender: TObject);
303	var
304	E : LongInt;
305	begin
306	if (ElemNum.Text = '') then
307	ElemNum.Text := '0';
308
309	if NOT CheckControls(ARec) then
310	begin
311	ShowMessage('One or more invalid entries');
312	Exit;
313	end;
314
315	E := StrToInt(ElemNum.Text);
316	MyLArray.Put(E,ARec);
317
318	LB1.Items[E] := IntToStr(ARec.X) + ', ' + IntToStr(ARec.Y);
319
320	MyLArray.Get(E,ARec);
321	FillControls;
322	end;
323
324
325	procedure TSTDlg.GetBtnClick(Sender: TObject);
326	var
327	E : LongInt;
328	begin
329	if (ElemNum.Text = '') then
330	ElemNum.Text := '0';
331
332	E := StrToInt(ElemNum.Text);
333	MyLArray.Get(E,ARec);
334
335	FillControls;
336	end;
337
338	procedure TSTDlg.SortBtnClick(Sender: TObject);
339	begin
340	SetBusy(True);
341	MyLArray.Sort(MyArraySort);
342	SetBusy(False);
343
344	FillListBox;
345	FillControls;
346	SetBusy(False);
347	end;
348
349	procedure TSTDlg.LB1DblClick(Sender: TObject);
350	begin
351	MyLArray.Get(LB1.ItemIndex,ARec);
352	ElemNum.Text := IntToStr(LB1.ItemIndex);
353	FillControls;
354	end;
355
356	procedure TSTDlg.LoadBtnClick(Sender: TObject);
357	begin
358	if (OD1.Execute) then
359	begin
360	if (NOT Assigned(MyLArray)) then
361	begin
362	UpdateButtons(False);
363	MyLArray := TStLArray.Create(5000, sizeof(ARec));
364	MyLArray.ElementsStorable := True;
365	end;
366
367	MyLArray.Clear;
368	MyLArray.LoadFromFile(OD1.FileName);
369
370	FillListBox;
371	FillControls;
372	UpdateButtons(True);
373	end;
374	end;
375
376	procedure TSTDlg.SaveBtnClick(Sender: TObject);
377	begin
378	if (SD1.Execute) then
379	MyLArray.StoreToFile(SD1.FileName);
380	end;
381
382
383	end.