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	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 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.