You've already forked lazarus-ccr
systools: Add units with container classes (and related demos)
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6146 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
85
components/systools/examples/priority_queue/expq.lpi
Normal file
85
components/systools/examples/priority_queue/expq.lpi
Normal file
@ -0,0 +1,85 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<UseDefaultCompilerOptions Value="True"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="expq"/>
|
||||
<Scaled Value="True"/>
|
||||
<ResourceType Value="res"/>
|
||||
<UseXPManifest Value="True"/>
|
||||
<XPManifest>
|
||||
<DpiAware Value="True"/>
|
||||
</XPManifest>
|
||||
<Icon Value="0"/>
|
||||
</General>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<FormatVersion Value="2"/>
|
||||
<Modes Count="0"/>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="2">
|
||||
<Item1>
|
||||
<PackageName Value="laz_systools"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item2>
|
||||
</RequiredPackages>
|
||||
<Units Count="2">
|
||||
<Unit0>
|
||||
<Filename Value="expq.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="expqu.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ComponentName Value="StDlg"/>
|
||||
<HasResources Value="True"/>
|
||||
<ResourceBaseClass Value="Form"/>
|
||||
<UnitName Value="ExPQU"/>
|
||||
</Unit1>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="expq"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Linking>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
44
components/systools/examples/priority_queue/expq.lpr
Normal file
44
components/systools/examples/priority_queue/expq.lpr
Normal file
@ -0,0 +1,44 @@
|
||||
(* ***** 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 ***** *)
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$mode DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
program expq;
|
||||
|
||||
uses
|
||||
Interfaces,
|
||||
Forms, lclversion,
|
||||
expqu in 'expqu.pas' {StDlg};
|
||||
|
||||
{$R *.res}
|
||||
|
||||
begin
|
||||
Application.Scaled := True;
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TStDlg, StDlg);
|
||||
Application.Run;
|
||||
end.
|
||||
161
components/systools/examples/priority_queue/expqu.lfm
Normal file
161
components/systools/examples/priority_queue/expqu.lfm
Normal file
@ -0,0 +1,161 @@
|
||||
object StDlg: TStDlg
|
||||
Left = 451
|
||||
Height = 335
|
||||
Top = 128
|
||||
Width = 376
|
||||
ActiveControl = CreateBtn
|
||||
BorderStyle = bsDialog
|
||||
Caption = 'Priority Queue (StPQueue) Example'
|
||||
ClientHeight = 335
|
||||
ClientWidth = 376
|
||||
Color = clBtnFace
|
||||
Font.Color = clWindowText
|
||||
OnClose = FormClose
|
||||
OnCreate = FormCreate
|
||||
Position = poScreenCenter
|
||||
ShowHint = True
|
||||
LCLVersion = '1.9.0.0'
|
||||
object ActionLabel: TLabel
|
||||
Left = 208
|
||||
Height = 15
|
||||
Top = 87
|
||||
Width = 105
|
||||
Caption = 'Most recent action'
|
||||
Font.Color = clWindowText
|
||||
Font.Style = [fsBold]
|
||||
ParentColor = False
|
||||
ParentFont = False
|
||||
end
|
||||
object QueueLabel: TLabel
|
||||
Left = 32
|
||||
Height = 15
|
||||
Top = 55
|
||||
Width = 75
|
||||
Caption = 'Jobs in queue'
|
||||
Font.Color = clWindowText
|
||||
Font.Style = [fsBold]
|
||||
ParentColor = False
|
||||
ParentFont = False
|
||||
end
|
||||
object JobLabel: TLabel
|
||||
Left = 136
|
||||
Height = 15
|
||||
Top = 8
|
||||
Width = 54
|
||||
Caption = 'Initial jobs'
|
||||
ParentColor = False
|
||||
end
|
||||
object CreateBtn: TButton
|
||||
Left = 32
|
||||
Height = 33
|
||||
Hint = 'Create new priority queue with specified initial # of jobs'
|
||||
Top = 12
|
||||
Width = 81
|
||||
Caption = 'Create'
|
||||
OnClick = CreateBtnClick
|
||||
TabOrder = 0
|
||||
end
|
||||
object ClearBtn: TButton
|
||||
Left = 244
|
||||
Height = 33
|
||||
Hint = 'Clear the queue'
|
||||
Top = 288
|
||||
Width = 81
|
||||
Caption = 'Clear'
|
||||
OnClick = ClearBtnClick
|
||||
TabOrder = 6
|
||||
end
|
||||
object LoadBtn: TButton
|
||||
Left = 32
|
||||
Height = 33
|
||||
Hint = 'Load previously saved stream file'
|
||||
Top = 288
|
||||
Width = 81
|
||||
Caption = 'Load'
|
||||
OnClick = LoadBtnClick
|
||||
TabOrder = 9
|
||||
end
|
||||
object SaveBtn: TButton
|
||||
Left = 128
|
||||
Height = 33
|
||||
Hint = 'Save current queue to stream file'
|
||||
Top = 288
|
||||
Width = 81
|
||||
Caption = 'Save'
|
||||
OnClick = SaveBtnClick
|
||||
TabOrder = 7
|
||||
end
|
||||
object InsertBtn: TButton
|
||||
Left = 244
|
||||
Height = 33
|
||||
Hint = 'Add another job to the queue'
|
||||
Top = 144
|
||||
Width = 81
|
||||
Caption = 'Insert'
|
||||
OnClick = InsertBtnClick
|
||||
TabOrder = 3
|
||||
end
|
||||
object DeleteMinBtn: TButton
|
||||
Left = 244
|
||||
Height = 33
|
||||
Hint = 'Remove the job with minimum priority from the queue'
|
||||
Top = 192
|
||||
Width = 81
|
||||
Caption = 'DeleteMin'
|
||||
OnClick = DeleteMinBtnClick
|
||||
TabOrder = 4
|
||||
end
|
||||
object DeleteMaxBtn: TButton
|
||||
Left = 244
|
||||
Height = 33
|
||||
Hint = 'Remove the job with highest priority from the queue'
|
||||
Top = 240
|
||||
Width = 81
|
||||
Caption = 'DeleteMax'
|
||||
OnClick = DeleteMaxBtnClick
|
||||
TabOrder = 5
|
||||
end
|
||||
object LB1: TListBox
|
||||
Left = 32
|
||||
Height = 201
|
||||
Hint = 'Shows the queued jobs in internal order. The first job is the lowest priority and the second is the highest.'
|
||||
Top = 72
|
||||
Width = 153
|
||||
ItemHeight = 0
|
||||
TabOrder = 8
|
||||
end
|
||||
object ActionEdit: TEdit
|
||||
Left = 208
|
||||
Height = 23
|
||||
Hint = 'Shows the action you performed last'
|
||||
Top = 104
|
||||
Width = 153
|
||||
ReadOnly = True
|
||||
TabStop = False
|
||||
TabOrder = 2
|
||||
end
|
||||
object JobEdit: TEdit
|
||||
Left = 136
|
||||
Height = 23
|
||||
Hint = 'Specify the number of jobs Create adds to the queue'
|
||||
Top = 24
|
||||
Width = 65
|
||||
TabOrder = 1
|
||||
end
|
||||
object OD1: TOpenDialog
|
||||
DefaultExt = '.stm'
|
||||
FileName = 'texpq.stm'
|
||||
Filter = '*.stm (stream files)|*.stm|*.* (all files)|*.*'
|
||||
Options = [ofFileMustExist]
|
||||
left = 340
|
||||
top = 50
|
||||
end
|
||||
object SD1: TSaveDialog
|
||||
DefaultExt = '.stm'
|
||||
FileName = 'texpq.stm'
|
||||
Filter = '*.stm (stream files)|*.stm|*.* (all files)|*.*'
|
||||
Options = [ofOverwritePrompt]
|
||||
left = 340
|
||||
top = 18
|
||||
end
|
||||
end
|
||||
316
components/systools/examples/priority_queue/expqu.pas
Normal file
316
components/systools/examples/priority_queue/expqu.pas
Normal file
@ -0,0 +1,316 @@
|
||||
(* ***** 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 ***** *)
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$mode DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
unit ExPQU;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFNDEF FPC}
|
||||
Windows, Messages,
|
||||
{$ENDIF}
|
||||
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
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$R *.lfm}
|
||||
{$ELSE}
|
||||
{$R *.DFM}
|
||||
{$ENDIF}
|
||||
|
||||
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.Items.BeginUpdate;
|
||||
try
|
||||
LB1.Clear;
|
||||
if Assigned(MyPQ) then
|
||||
MyPQ.Iterate(MyListBoxAdd, LB1);
|
||||
finally
|
||||
LB1.Items.EndUpdate;
|
||||
end;
|
||||
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.
|
||||
Reference in New Issue
Block a user