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

interface

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

  StBase, StPQueue;

const
  InitSize =  50;
  Delta    = 100;
  DefJobs  =  15;

type
  TPQRec = record
    Priority : LongInt;
    Name : string[10];
  end;
  PPQRec = ^TPQRec;

  TStDlg = class(TForm)
    CreateBtn: TButton;
    ClearBtn: TButton;
    LoadBtn: TButton;
    SaveBtn: TButton;
    InsertBtn: TButton;
    DeleteMinBtn: TButton;
    DeleteMaxBtn: TButton;
    LB1: TListBox;
    OD1: TOpenDialog;
    SD1: TSaveDialog;
    ActionEdit: TEdit;
    ActionLabel: TLabel;
    QueueLabel: TLabel;
    JobEdit: TEdit;
    JobLabel: TLabel;

    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure CreateBtnClick(Sender: TObject);
    procedure ClearBtnClick(Sender: TObject);
    procedure LoadBtnClick(Sender: TObject);
    procedure SaveBtnClick(Sender: TObject);
    procedure InsertBtnClick(Sender: TObject);
    procedure DeleteMinBtnClick(Sender: TObject);
    procedure DeleteMaxBtnClick(Sender: TObject);
    procedure JobSpinDownClick(Sender: TObject);
    procedure JobSpinUpClick(Sender: TObject);
  private
    MyPQ : TStPQueue;
    procedure FillListBox;
    function InsertItem : PPQRec;
  end;

var
  StDlg: TStDlg;

implementation

{$R *.DFM}

function MyCompare(Data1, Data2 : Pointer) : Integer; far;
begin
  Result := PPQRec(Data1)^.Priority-PPQRec(Data2)^.Priority;
end;

procedure MyDelNodeData(Data : pointer); far;
begin
  Dispose(PPQRec(Data));
end;

function MyLoadData(Reader : TReader) : Pointer; far;
var
  pn : PPQRec;
begin
  New(pn);
  pn^.Priority := Reader.ReadInteger;
  pn^.Name := Reader.ReadString;
  Result := pn;
end;

procedure MyStoreData(Writer : TWriter; Data : Pointer); far;
begin
  Writer.WriteInteger(PPQRec(Data)^.Priority);
  Writer.WriteString(PPQRec(Data)^.Name);
end;

function JobString(pn : PPQRec) : string;
begin
  with pn^ do
    Result := IntToStr(Priority)+'      '+Name;
end;

function MyListBoxAdd(Container : TStContainer;
  Data, OtherData : Pointer) : Boolean; far;
begin
  TListBox(OtherData).Items.Add(JobString(PPQRec(Data)));
  Result := true;
end;

{--------------------------------------------------------------}

procedure TStDlg.FormCreate(Sender: TObject);
begin
  RegisterClasses([TStPQueue]);
  ClearBtn.Enabled := false;
  SaveBtn.Enabled := false;
  LoadBtn.Enabled := false;
  InsertBtn.Enabled := false;
  DeleteMinBtn.Enabled := false;
  DeleteMaxBtn.Enabled := false;
  JobEdit.Text := IntToStr(DefJobs);
end;

procedure TStDlg.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if Assigned(MyPQ) then
    MyPQ.Free;
end;

procedure TStDlg.FillListBox;
var
  benabled : boolean;
begin
  Screen.Cursor := crHourGlass;
  LB1.Clear;
  LB1.Perform(WM_SETREDRAW, 0, 0);
  if Assigned(MyPQ) then
    MyPQ.Iterate(MyListBoxAdd, LB1);
  LB1.Perform(WM_SETREDRAW, 1, 0);
  LB1.Update;
  benabled := Assigned(MyPQ) and (MyPQ.Count > 0);
  DeleteMinBtn.Enabled := benabled;
  DeleteMaxBtn.Enabled := benabled;
  Screen.Cursor := crDefault;
end;

function TStDlg.InsertItem : PPQRec;
var
  i : integer;
  pn : PPQRec;
begin
  {create a new item}
  new(pn);
  with pn^ do begin
    {give it a random priority and a random name}
    priority := 100+random(100);
    name := 'job ';
    for i := 1 to 8 do
      name := name+Char(random(26)+Byte('A'));
  end;
  {insert item into priority queue}
  MyPQ.Insert(pn);
  Result := pn;
end;

procedure TStDlg.CreateBtnClick(Sender: TObject);
var
  i, jobs : integer;
begin
  if Assigned(MyPQ) then
    MyPQ.Free;

  MyPQ := TStPQueue.Create(InitSize, Delta);
  MyPQ.Compare := MyCompare;
  MyPQ.DisposeData := MyDelNodeData;
  MyPQ.LoadData := MyLoadData;
  MyPQ.StoreData := MyStoreData;

  {determine how many jobs to add}
  try
    jobs := StrToInt(JobEdit.Text);
    if (jobs < 1) then
      jobs := 1
    else if (jobs > 1000) then
      jobs := 1000;
  except
    jobs := DefJobs;
  end;
  JobEdit.Text := IntToStr(jobs);

  {add random jobs}
  Randomize;
  for i := 1 to jobs do
    InsertItem;

  {update form display}
  FillListBox;
  ActionEdit.Text := 'created';
  ClearBtn.Enabled := true;
  SaveBtn.Enabled := true;
  InsertBtn.Enabled := true;
end;

procedure TStDlg.ClearBtnClick(Sender: TObject);
begin
  MyPQ.Clear;
  FillListBox;
  ActionEdit.Text := 'cleared';
end;

procedure TStDlg.InsertBtnClick(Sender: TObject);
var
  pn : PPQRec;
begin
  pn := InsertItem;
  ActionEdit.Text := JobString(pn)+' inserted';
  FillListBox;
end;

procedure TStDlg.DeleteMinBtnClick(Sender: TObject);
var
  pn : PPQRec;
begin
  pn := PPQRec(MyPQ.DeleteMin);
  ActionEdit.Text := JobString(pn)+' deleted';
  MyPQ.DisposeData(pn);
  FillListBox;
end;

procedure TStDlg.DeleteMaxBtnClick(Sender: TObject);
var
  pn : PPQRec;
begin
  pn := PPQRec(MyPQ.DeleteMax);
  ActionEdit.Text := JobString(pn)+' deleted';
  MyPQ.DisposeData(pn);
  FillListBox;
end;

procedure TStDlg.JobSpinDownClick(Sender: TObject);
var
  jobs : integer;
begin
  try
    jobs := StrToInt(JobEdit.Text);
  except
    jobs := DefJobs;
  end;
  if (jobs > 1) then
    dec(jobs);
  JobEdit.Text := IntToStr(jobs);
end;

procedure TStDlg.JobSpinUpClick(Sender: TObject);
var
  jobs : integer;
begin
  try
    jobs := StrToInt(JobEdit.Text);
  except
    jobs := DefJobs;
  end;
  if (jobs < 1000) then
    inc(jobs);
  JobEdit.Text := IntToStr(jobs);
end;

procedure TStDlg.LoadBtnClick(Sender: TObject);
begin
  if (OD1.Execute) then begin
    MyPQ.LoadFromFile(OD1.FileName);
    FillListBox;
    ActionEdit.Text := 'loaded';
  end;
end;

procedure TStDlg.SaveBtnClick(Sender: TObject);
begin
  if (SD1.Execute) then begin
    MyPQ.StoreToFile(SD1.FileName);
    LoadBtn.Enabled := true;
    ActionEdit.Text := 'saved';
  end;
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 ExPQU;
27
28	interface
29
30	uses
31	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
32
33	StBase, StPQueue;
34
35	const
36	InitSize = 50;
37	Delta = 100;
38	DefJobs = 15;
39
40	type
41	TPQRec = record
42	Priority : LongInt;
43	Name : string[10];
44	end;
45	PPQRec = ^TPQRec;
46
47	TStDlg = class(TForm)
48	CreateBtn: TButton;
49	ClearBtn: TButton;
50	LoadBtn: TButton;
51	SaveBtn: TButton;
52	InsertBtn: TButton;
53	DeleteMinBtn: TButton;
54	DeleteMaxBtn: TButton;
55	LB1: TListBox;
56	OD1: TOpenDialog;
57	SD1: TSaveDialog;
58	ActionEdit: TEdit;
59	ActionLabel: TLabel;
60	QueueLabel: TLabel;
61	JobEdit: TEdit;
62	JobLabel: TLabel;
63
64	procedure FormCreate(Sender: TObject);
65	procedure FormClose(Sender: TObject; var Action: TCloseAction);
66	procedure CreateBtnClick(Sender: TObject);
67	procedure ClearBtnClick(Sender: TObject);
68	procedure LoadBtnClick(Sender: TObject);
69	procedure SaveBtnClick(Sender: TObject);
70	procedure InsertBtnClick(Sender: TObject);
71	procedure DeleteMinBtnClick(Sender: TObject);
72	procedure DeleteMaxBtnClick(Sender: TObject);
73	procedure JobSpinDownClick(Sender: TObject);
74	procedure JobSpinUpClick(Sender: TObject);
75	private
76	MyPQ : TStPQueue;
77	procedure FillListBox;
78	function InsertItem : PPQRec;
79	end;
80
81	var
82	StDlg: TStDlg;
83
84	implementation
85
86	{$R *.DFM}
87
88	function MyCompare(Data1, Data2 : Pointer) : Integer; far;
89	begin
90	Result := PPQRec(Data1)^.Priority-PPQRec(Data2)^.Priority;
91	end;
92
93	procedure MyDelNodeData(Data : pointer); far;
94	begin
95	Dispose(PPQRec(Data));
96	end;
97
98	function MyLoadData(Reader : TReader) : Pointer; far;
99	var
100	pn : PPQRec;
101	begin
102	New(pn);
103	pn^.Priority := Reader.ReadInteger;
104	pn^.Name := Reader.ReadString;
105	Result := pn;
106	end;
107
108	procedure MyStoreData(Writer : TWriter; Data : Pointer); far;
109	begin
110	Writer.WriteInteger(PPQRec(Data)^.Priority);
111	Writer.WriteString(PPQRec(Data)^.Name);
112	end;
113
114	function JobString(pn : PPQRec) : string;
115	begin
116	with pn^ do
117	Result := IntToStr(Priority)+' '+Name;
118	end;
119
120	function MyListBoxAdd(Container : TStContainer;
121	Data, OtherData : Pointer) : Boolean; far;
122	begin
123	TListBox(OtherData).Items.Add(JobString(PPQRec(Data)));
124	Result := true;
125	end;
126
127	{--------------------------------------------------------------}
128
129	procedure TStDlg.FormCreate(Sender: TObject);
130	begin
131	RegisterClasses([TStPQueue]);
132	ClearBtn.Enabled := false;
133	SaveBtn.Enabled := false;
134	LoadBtn.Enabled := false;
135	InsertBtn.Enabled := false;
136	DeleteMinBtn.Enabled := false;
137	DeleteMaxBtn.Enabled := false;
138	JobEdit.Text := IntToStr(DefJobs);
139	end;
140
141	procedure TStDlg.FormClose(Sender: TObject; var Action: TCloseAction);
142	begin
143	if Assigned(MyPQ) then
144	MyPQ.Free;
145	end;
146
147	procedure TStDlg.FillListBox;
148	var
149	benabled : boolean;
150	begin
151	Screen.Cursor := crHourGlass;
152	LB1.Clear;
153	LB1.Perform(WM_SETREDRAW, 0, 0);
154	if Assigned(MyPQ) then
155	MyPQ.Iterate(MyListBoxAdd, LB1);
156	LB1.Perform(WM_SETREDRAW, 1, 0);
157	LB1.Update;
158	benabled := Assigned(MyPQ) and (MyPQ.Count > 0);
159	DeleteMinBtn.Enabled := benabled;
160	DeleteMaxBtn.Enabled := benabled;
161	Screen.Cursor := crDefault;
162	end;
163
164	function TStDlg.InsertItem : PPQRec;
165	var
166	i : integer;
167	pn : PPQRec;
168	begin
169	{create a new item}
170	new(pn);
171	with pn^ do begin
172	{give it a random priority and a random name}
173	priority := 100+random(100);
174	name := 'job ';
175	for i := 1 to 8 do
176	name := name+Char(random(26)+Byte('A'));
177	end;
178	{insert item into priority queue}
179	MyPQ.Insert(pn);
180	Result := pn;
181	end;
182
183	procedure TStDlg.CreateBtnClick(Sender: TObject);
184	var
185	i, jobs : integer;
186	begin
187	if Assigned(MyPQ) then
188	MyPQ.Free;
189
190	MyPQ := TStPQueue.Create(InitSize, Delta);
191	MyPQ.Compare := MyCompare;
192	MyPQ.DisposeData := MyDelNodeData;
193	MyPQ.LoadData := MyLoadData;
194	MyPQ.StoreData := MyStoreData;
195
196	{determine how many jobs to add}
197	try
198	jobs := StrToInt(JobEdit.Text);
199	if (jobs < 1) then
200	jobs := 1
201	else if (jobs > 1000) then
202	jobs := 1000;
203	except
204	jobs := DefJobs;
205	end;
206	JobEdit.Text := IntToStr(jobs);
207
208	{add random jobs}
209	Randomize;
210	for i := 1 to jobs do
211	InsertItem;
212
213	{update form display}
214	FillListBox;
215	ActionEdit.Text := 'created';
216	ClearBtn.Enabled := true;
217	SaveBtn.Enabled := true;
218	InsertBtn.Enabled := true;
219	end;
220
221	procedure TStDlg.ClearBtnClick(Sender: TObject);
222	begin
223	MyPQ.Clear;
224	FillListBox;
225	ActionEdit.Text := 'cleared';
226	end;
227
228	procedure TStDlg.InsertBtnClick(Sender: TObject);
229	var
230	pn : PPQRec;
231	begin
232	pn := InsertItem;
233	ActionEdit.Text := JobString(pn)+' inserted';
234	FillListBox;
235	end;
236
237	procedure TStDlg.DeleteMinBtnClick(Sender: TObject);
238	var
239	pn : PPQRec;
240	begin
241	pn := PPQRec(MyPQ.DeleteMin);
242	ActionEdit.Text := JobString(pn)+' deleted';
243	MyPQ.DisposeData(pn);
244	FillListBox;
245	end;
246
247	procedure TStDlg.DeleteMaxBtnClick(Sender: TObject);
248	var
249	pn : PPQRec;
250	begin
251	pn := PPQRec(MyPQ.DeleteMax);
252	ActionEdit.Text := JobString(pn)+' deleted';
253	MyPQ.DisposeData(pn);
254	FillListBox;
255	end;
256
257	procedure TStDlg.JobSpinDownClick(Sender: TObject);
258	var
259	jobs : integer;
260	begin
261	try
262	jobs := StrToInt(JobEdit.Text);
263	except
264	jobs := DefJobs;
265	end;
266	if (jobs > 1) then
267	dec(jobs);
268	JobEdit.Text := IntToStr(jobs);
269	end;
270
271	procedure TStDlg.JobSpinUpClick(Sender: TObject);
272	var
273	jobs : integer;
274	begin
275	try
276	jobs := StrToInt(JobEdit.Text);
277	except
278	jobs := DefJobs;
279	end;
280	if (jobs < 1000) then
281	inc(jobs);
282	JobEdit.Text := IntToStr(jobs);
283	end;
284
285	procedure TStDlg.LoadBtnClick(Sender: TObject);
286	begin
287	if (OD1.Execute) then begin
288	MyPQ.LoadFromFile(OD1.FileName);
289	FillListBox;
290	ActionEdit.Text := 'loaded';
291	end;
292	end;
293
294	procedure TStDlg.SaveBtnClick(Sender: TObject);
295	begin
296	if (SD1.Execute) then begin
297	MyPQ.StoreToFile(SD1.FileName);
298	LoadBtn.Enabled := true;
299	ActionEdit.Text := 'saved';
300	end;
301	end;
302
303	end.