pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

systools: Add units with container classes (and related demos)

Browse Source 
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
2018-01-17 16:26:27 +00:00
parent d01c4e2db4
commit 36b42951dd
47 changed files with 11372 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

86
components/systools/examples/bits/exbits.lpi Normal file
View File

@@ -0,0 +1,86 @@
<?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="exbits"/>
<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="exbits.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Exbits"/>
</Unit0>
<Unit1>
<Filename Value="exbitsu.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="STDlg"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ExBitsU"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="exbits"/>
</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>

46
components/systools/examples/bits/exbits.lpr Normal file
View File

@@ -0,0 +1,46 @@
(* ***** 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 Exbits;
uses
Interfaces,
Forms, lclversion,
exbitsu in 'exbitsu.pas' {STDlg};
{$R *.res}
begin
{$IFDEF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TSTDlg, STDlg);
Application.Run;
end.

227
components/systools/examples/bits/exbitsu.lfm Normal file
View File

@@ -0,0 +1,227 @@
object STDlg: TSTDlg
Left = 277
Height = 260
Top = 169
Width = 478
BorderStyle = bsDialog
Caption = 'StBits Example'
ClientHeight = 260
ClientWidth = 478
Color = clBtnFace
Font.Color = clBlack
OnActivate = FormActivate
OnClose = FormClose
OnCreate = FormCreate
Position = poScreenCenter
ShowHint = True
LCLVersion = '1.9.0.0'
object Label2: TLabel
Left = 12
Height = 15
Top = 54
Width = 106
Caption = 'Elements in BitSet: 0'
ParentColor = False
end
object Label1: TLabel
Left = 152
Height = 15
Top = 21
Width = 244
Caption = 'In entry fields below, enter a number from: '
Font.Color = clBlack
Font.Style = [fsBold]
ParentColor = False
ParentFont = False
end
object CreateBtn: TButton
Left = 13
Height = 30
Hint = 'Create MyBits'
Top = 17
Width = 66
Caption = 'Create'
OnClick = CreateBtnClick
TabOrder = 0
end
object NumElemsValue: TEdit
Left = 85
Height = 23
Hint = 'Number of bits'
Top = 22
Width = 35
TabOrder = 1
Text = '100'
end
object ClearAllBtn: TButton
Left = 29
Height = 30
Hint = 'Clear all bits'
Top = 157
Width = 66
Caption = 'Clear All'
OnClick = ClearAllBtnClick
TabOrder = 4
end
object SetAllBtn: TButton
Left = 29
Height = 30
Hint = 'Set all bits'
Top = 83
Width = 66
Caption = 'Set All'
OnClick = SetAllBtnClick
TabOrder = 2
end
object InvertAllBtn: TButton
Left = 29
Height = 30
Hint = 'Invert all bits'
Top = 120
Width = 66
Caption = 'Invert All'
OnClick = InvertAllBtnClick
TabOrder = 3
end
object SetBitBtn: TButton
Left = 154
Height = 30
Hint = 'Set a bit to 1'
Top = 156
Width = 66
Caption = 'Set Bit'
OnClick = SetBitBtnClick
TabOrder = 9
end
object SetBitValue: TEdit
Left = 228
Height = 23
Hint = 'Element?'
Top = 162
Width = 41
TabOrder = 10
end
object ClearBitBtn: TButton
Left = 293
Height = 30
Hint = 'Clear a bit'
Top = 103
Width = 66
Caption = 'Clear Bit'
OnClick = ClearBitBtnClick
TabOrder = 14
end
object ClearBitValue: TEdit
Left = 370
Height = 23
Hint = 'Element?'
Top = 106
Width = 41
TabOrder = 15
end
object IsBitSetBtn: TButton
Left = 154
Height = 30
Hint = 'Check bit state'
Top = 53
Width = 66
Caption = 'Bit Set?'
OnClick = IsBitSetBtnClick
TabOrder = 5
end
object IsBitSetValue: TEdit
Left = 228
Height = 23
Hint = 'Element?'
Top = 58
Width = 39
TabOrder = 6
end
object ControlBitBtn: TButton
Left = 293
Height = 30
Hint = 'Set a bit''s value'
Top = 52
Width = 66
Caption = 'Control Bit'
OnClick = ControlBitBtnClick
TabOrder = 11
end
object ControlBitValue: TEdit
Left = 366
Height = 23
Hint = 'Element?'
Top = 58
Width = 41
TabOrder = 12
end
object BitOnCB: TCheckBox
Left = 414
Height = 19
Hint = 'Bit state'
Top = 59
Width = 53
Caption = 'Bit On'
TabOrder = 13
end
object ToggleBitBtn: TButton
Left = 154
Height = 30
Hint = 'Invert bit value'
Top = 105
Width = 66
Caption = 'Toggle Bit'
OnClick = ToggleBitBtnClick
TabOrder = 7
end
object ToggleBitValue: TEdit
Left = 228
Height = 23
Hint = 'Element?'
Top = 109
Width = 39
TabOrder = 8
end
object Msg1: TMemo
Left = 294
Height = 59
Hint = 'Messages'
Top = 142
Width = 167
Lines.Strings = (
''
)
TabOrder = 16
end
object LoadBtn: TButton
Left = 30
Height = 33
Top = 212
Width = 89
Caption = 'Load'
OnClick = LoadBtnClick
TabOrder = 17
end
object SaveBtn: TButton
Left = 154
Height = 33
Top = 212
Width = 89
Caption = 'Save'
OnClick = SaveBtnClick
TabOrder = 18
end
object OD1: TOpenDialog
DefaultExt = '.bsf'
Filter = '*.bsf (BitSet files)|*.bsf|*.* (All files)|*.*'
left = 252
top = 212
end
object SD1: TSaveDialog
DefaultExt = '.bsf'
Filter = '*.bsf (BitSet files)|*.bsf|*.* (All files)|*.*'
Options = [ofOverwritePrompt]
left = 292
top = 212
end
end

365
components/systools/examples/bits/exbitsu.pas Normal file
View File

@@ -0,0 +1,365 @@
(* ***** 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 ExBitsU;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, ExtCtrls;
type
TSTDlg = class(TForm)
CreateBtn: TButton;
NumElemsValue: TEdit;
Label2: TLabel;
ClearAllBtn: TButton;
SetAllBtn: TButton;
InvertAllBtn: TButton;
Label1: TLabel;
SetBitBtn: TButton;
SetBitValue: TEdit;
ClearBitBtn: TButton;
ClearBitValue: TEdit;
IsBitSetBtn: TButton;
IsBitSetValue: TEdit;
ControlBitBtn: TButton;
ControlBitValue: TEdit;
BitOnCB: TCheckBox;
ToggleBitBtn: TButton;
ToggleBitValue: TEdit;
Msg1: TMemo;
LoadBtn: TButton;
SaveBtn: TButton;
OD1: TOpenDialog;
SD1: TSaveDialog;
procedure CreateBtnClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ClearAllBtnClick(Sender: TObject);
procedure SetAllBtnClick(Sender: TObject);
procedure InvertAllBtnClick(Sender: TObject);
procedure SetBitBtnClick(Sender: TObject);
procedure ControlBitBtnClick(Sender: TObject);
procedure ClearBitBtnClick(Sender: TObject);
procedure IsBitSetBtnClick(Sender: TObject);
procedure ToggleBitBtnClick(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure LoadBtnClick(Sender: TObject);
procedure SaveBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure UpdateButtons(BitsOK : Boolean);
function CheckValue(S : string; var N : longint) : Boolean;
function GetTFString(N : LongInt) : string;
end;
var
STDlg: TSTDlg;
implementation
{$R *.lfm}
uses
StConst,
StBase,
StBits;
var
MyBits : TStBits;
procedure TSTDlg.FormCreate(Sender: TObject);
begin
RegisterClass(TStBits);
UpdateButtons(False);
end;
procedure TSTDlg.UpdateButtons(BitsOK : Boolean);
begin
IsBitSetBtn.Enabled := BitsOK;
ControlBitBtn.Enabled := BitsOK;
SetAllBtn.Enabled := BitsOK;
InvertAllBtn.Enabled := BitsOK;
ClearAllBtn.Enabled := BitsOK;
ToggleBitBtn.Enabled := BitsOK;
SetBitBtn.Enabled := BitsOK;
ClearBitBtn.Enabled := BitsOK;
SaveBtn.Enabled := BitsOK;
end;
procedure TSTDlg.FormActivate(Sender: TObject);
begin
IsBitSetValue.Text := '-1';
ToggleBitValue.Text := '-1';
SetBitValue.Text := '-1';
ControlBitValue.Text := '-1';
ClearBitValue.Text := '-1';
Msg1.Lines.Clear;
Msg1.Lines.Add('BitSet not created');
end;
procedure TSTDlg.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
MyBits.Free;
end;
procedure TSTDlg.CreateBtnClick(Sender: TObject);
var
MaxBits : longint;
begin
Msg1.Lines.Clear;
if (NumElemsValue.Text = '') then
NumElemsValue.Text := '50';
MaxBits := StrToInt(NumElemsValue.Text);
if (MaxBits < 1) OR (MaxBits > 9999) then
begin
ShowMessage('Value out of range (1 - 9999)');
Exit;
end;
Msg1.Lines.Clear;
if Assigned(MyBits) then
MyBits.Free;
UpdateButtons(False);
MyBits := TStBits.Create(MaxBits);
Label1.Caption := 'In entry fields below, enter a value from 0 to '
+ IntToStr(MaxBits);
Label2.Caption := 'Elements in BitSet: ' + IntToStr(MyBits.Max+1);
IsBitSetValue.Text := '0';
ToggleBitValue.Text := '0';
SetBitValue.Text := '0';
ControlBitValue.Text := '0';
ClearBitValue.Text := '0';
Msg1.Lines.Add('BitSet created');
Msg1.Lines.Add(IntToStr(MyBits.Count));
UpdateButtons(True);
end;
procedure TSTDlg.ClearAllBtnClick(Sender: TObject);
begin
Msg1.Lines.Clear;
MyBits.Clear;
Msg1.Lines.Add('Bits Cleared');
end;
procedure TSTDlg.SetAllBtnClick(Sender: TObject);
begin
Msg1.Lines.Clear;
MyBits.SetBits;
Msg1.Lines.Add('Bits Set');
end;
procedure TSTDlg.InvertAllBtnClick(Sender: TObject);
begin
Msg1.Lines.Clear;
MyBits.InvertBits;
Msg1.Lines.Add('Bits Inverted');
end;
function TSTDlg.CheckValue(S : String; var N : longint) : Boolean;
begin
Result := FALSE;
if (S = '') then
begin
ShowMessage('No value entered');
Exit;
end;
N := StrToInt(S);
if (N < 0) or (N > MyBits.Max) then
begin
ShowMessage('Number out of range');
Exit;
end;
Result := TRUE;
end;
function TSTDlg.GetTFString(N : LongInt) : string;
begin
if MyBits.BitIsSet(N) then
Result := 'TRUE'
else
Result := 'FALSE';
end;
procedure TSTDlg.SetBitBtnClick(Sender: TObject);
var
BitNum : longint;
WasStr,
NowStr : string[5];
begin
if NOT CheckValue(SetBitValue.Text,BitNum) then
Exit;
WasStr := GetTFString(BitNum);
MyBits.SetBit(BitNum);
NowStr := GetTFString(BitNum);
Msg1.Lines.Clear;
Msg1.Lines.Add('Bit was: ' + WasStr);
Msg1.Lines.Add('Bit is now: ' + NowStr);
end;
procedure TSTDlg.ControlBitBtnClick(Sender: TObject);
var
BitNum : longint;
WasStr,
NowStr : string[5];
begin
if NOT CheckValue(ControlBitValue.Text,BitNum) then
Exit;
WasStr := GetTFString(BitNum);
MyBits.ControlBit(BitNum,BitOnCB.Checked);
NowStr := GetTFString(BitNum);
Msg1.Lines.Clear;
Msg1.Lines.Add('Bit was: ' + WasStr);
Msg1.Lines.Add('Bit is now: ' + NowStr);
end;
procedure TSTDlg.ClearBitBtnClick(Sender: TObject);
var
BitNum : longint;
WasStr,
NowStr : string;
begin
if NOT CheckValue(ClearBitValue.Text,BitNum) then
Exit;
WasStr := GetTFString(BitNum);
MyBits.ClearBit(BitNum);
NowStr := GetTFString(BitNum);
Msg1.Lines.Clear;
Msg1.Lines.Add('Bit was: ' + WasStr);
Msg1.Lines.Add('Bit is now: ' + NowStr);
end;
procedure TSTDlg.IsBitSetBtnClick(Sender: TObject);
var
BitNum : longint;
begin
if NOT CheckValue(IsBitSetValue.Text,BitNum) then
Exit;
Msg1.Lines.Clear;
if (MyBits.BitIsSet(BitNum)) then
Msg1.Lines.Add('Bit is set')
else
Msg1.Lines.Add( 'Bit not set');
end;
procedure TSTDlg.ToggleBitBtnClick(Sender: TObject);
var
BitNum : longint;
WasStr,
NowStr : string;
begin
if NOT CheckValue(ToggleBitValue.Text,BitNum) then
Exit;
WasStr := GetTFString(BitNum);
MyBits.ToggleBit(BitNum);
NowStr := GetTFString(BitNum);
Msg1.Lines.Clear;
Msg1.Lines.Add('Bit was: ' + WasStr);
Msg1.Lines.Add('Bit is now: ' + NowStr);
end;
procedure TSTDlg.LoadBtnClick(Sender: TObject);
begin
if (OD1.Execute) then
begin
if (NOT Assigned(MyBits)) then
begin
{create a minimum sized bitset - load will resize it}
MyBits := TStBits.Create(1);
if NOT (Assigned(MyBits)) then
begin
Msg1.Lines.Add('BitSet Create Failed');
UpdateButtons(False);
Exit;
end;
end;
MyBits.Clear;
MyBits.LoadFromFile(OD1.FileName);
Label1.Caption := 'In entry fields below, enter a value from 0 to '
+ IntToStr(MyBits.Max);
Label2.Caption := 'Elements in BitSet: ' + IntToStr(MyBits.Max+1);
IsBitSetValue.Text := '0';
ToggleBitValue.Text := '0';
SetBitValue.Text := '0';
ControlBitValue.Text := '0';
ClearBitValue.Text := '0';
Msg1.Clear;
Msg1.Lines.Add('BitSet loaded');
UpdateButtons(True);
end;
end;
procedure TSTDlg.SaveBtnClick(Sender: TObject);
begin
if (SD1.Execute) then
begin
MyBits.StoreToFile(SD1.FileName);
Msg1.Clear;
Msg1.Lines.Add('BitSet saved');
end;
end;
end.

84
components/systools/examples/collection/excoll.lpi Normal file
View File

@@ -0,0 +1,84 @@
<?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="excoll"/>
<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="excoll.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Excoll"/>
</Unit0>
<Unit1>
<Filename Value="excollu.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
<UnitName Value="ExCollU"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="excoll"/>
</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>

46
components/systools/examples/collection/excoll.lpr Normal file
View File

@@ -0,0 +1,46 @@
(* ***** 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 Excoll;
uses
Interfaces,
Forms, lclversion,
excollu in 'excollu.pas' {STDlg};
{$R *.res}
begin
{$IF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TSTDlg, STDlg);
Application.Run;
end.

239
components/systools/examples/collection/excollu.lfm Normal file
View File

@@ -0,0 +1,239 @@
object STDlg: TSTDlg
Left = 243
Height = 276
Top = 216
Width = 407
BorderStyle = bsDialog
Caption = 'StCollection Example'
ClientHeight = 276
ClientWidth = 407
Color = clBtnFace
Font.Color = clBlack
OnClose = FormClose
OnCreate = FormCreate
Position = poScreenCenter
ShowHint = True
LCLVersion = '1.9.0.0'
object Label8: TLabel
Left = 196
Height = 15
Top = 142
Width = 43
Caption = 'Element'
ParentColor = False
end
object Label1: TLabel
Left = 196
Height = 15
Top = 174
Width = 22
Caption = 'First'
ParentColor = False
end
object Label2: TLabel
Left = 196
Height = 15
Top = 200
Width = 21
Caption = 'Last'
ParentColor = False
end
object Label3: TLabel
Left = 334
Height = 15
Top = 200
Width = 21
Caption = 'Age'
ParentColor = False
end
object CreateBtn: TButton
Left = 12
Height = 29
Hint = 'Create MyCollection'
Top = 11
Width = 55
Caption = 'Create'
OnClick = CreateBtnClick
TabOrder = 0
end
object LB1: TListBox
Left = 12
Height = 207
Hint = 'DblClk to remove selected item'
Top = 51
Width = 177
ItemHeight = 0
OnClick = LB1Click
OnDblClick = LB1DblClick
TabOrder = 15
end
object ClearBtn: TButton
Left = 73
Height = 29
Hint = 'Clear collection'
Top = 11
Width = 55
Caption = 'Clear'
OnClick = ClearBtnClick
TabOrder = 1
end
object PackBtn: TButton
Left = 134
Height = 29
Hint = 'Pack collection'
Top = 11
Width = 55
Caption = 'Pack'
OnClick = PackBtnClick
TabOrder = 2
end
object EffBtn: TButton
Left = 228
Height = 29
Hint = 'Get efficiency'
Top = 92
Width = 70
Caption = 'Efficiency'
OnClick = EffBtnClick
TabOrder = 9
end
object Edit1: TEdit
Left = 308
Height = 23
Hint = '0-100%'
Top = 95
Width = 49
ReadOnly = True
TabStop = False
TabOrder = 10
end
object Edit3: TEdit
Left = 232
Height = 23
Hint = 'Enter 1..10 characters'
Top = 170
Width = 67
MaxLength = 10
TabOrder = 12
end
object Edit2: TEdit
Left = 254
Height = 23
Hint = 'Element?'
Top = 138
Width = 29
TabOrder = 11
Text = '0'
end
object AtBtn: TButton
Left = 196
Height = 29
Hint = 'Get value'
Top = 12
Width = 61
Caption = 'At'
OnClick = AtBtnClick
TabOrder = 3
end
object AtInsBtn: TButton
Left = 264
Height = 29
Hint = 'Insert value'
Top = 12
Width = 61
Caption = 'At Insert'
OnClick = AtInsBtnClick
TabOrder = 4
end
object AtPutBtn: TButton
Left = 332
Height = 29
Hint = 'Change value'
Top = 12
Width = 61
Caption = 'At Put'
OnClick = AtPutBtnClick
TabOrder = 5
end
object DelBtn: TButton
Left = 196
Height = 29
Hint = 'Delete first match'
Top = 49
Width = 61
Caption = 'Delete'
OnClick = DelBtnClick
TabOrder = 6
end
object AtDelBtn: TButton
Left = 264
Height = 29
Hint = 'Delete item'
Top = 49
Width = 61
Caption = 'At Delete'
OnClick = AtDelBtnClick
TabOrder = 7
end
object InsBtn: TButton
Left = 332
Height = 29
Hint = 'Insert at end'
Top = 49
Width = 61
Caption = 'Insert'
OnClick = InsBtnClick
TabOrder = 8
end
object Edit4: TEdit
Left = 232
Height = 23
Hint = 'Enter 1..15 characters'
Top = 196
Width = 95
MaxLength = 15
TabOrder = 13
end
object Edit5: TEdit
Left = 360
Height = 23
Hint = 'Enter number'
Top = 196
Width = 35
MaxLength = 3
TabOrder = 14
end
object LoadBtn: TButton
Left = 222
Height = 29
Hint = 'Load from file'
Top = 229
Width = 61
Caption = 'Load'
OnClick = LoadBtnClick
TabOrder = 16
end
object SaveBtn: TButton
Left = 298
Height = 29
Hint = 'Save to file'
Top = 229
Width = 61
Caption = 'Save'
OnClick = SaveBtnClick
TabOrder = 17
end
object OD1: TOpenDialog
DefaultExt = '.col'
Filter = '*.col (Collection files)|*.col|*.* (All files)|*.*'
left = 318
top = 134
end
object SD1: TSaveDialog
DefaultExt = '.col'
Filter = '*.col (Collection files)|*.col|*.* (All files)|*.*'
Options = [ofOverwritePrompt]
left = 354
top = 134
end
end

530
components/systools/examples/collection/excollu.pas Normal file
View File

@@ -0,0 +1,530 @@
(* ***** 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 ExCollU;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, ExtCtrls,
StConst, StBase, StColl;
type
S10 = string[10];
S15 = string[15];
ARecord = record
First : S10;
Last : S15;
Age : Integer;
end;
TSTDlg = class(TForm)
CreateBtn: TButton;
LB1: TListBox;
ClearBtn: TButton;
PackBtn: TButton;
EffBtn: TButton;
Edit1: TEdit;
Edit3: TEdit;
Label8: TLabel;
Edit2: TEdit;
AtBtn: TButton;
AtInsBtn: TButton;
AtPutBtn: TButton;
DelBtn: TButton;
AtDelBtn: TButton;
InsBtn: TButton;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
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 PackBtnClick(Sender: TObject);
procedure EffBtnClick(Sender: TObject);
procedure AtBtnClick(Sender: TObject);
procedure AtInsBtnClick(Sender: TObject);
procedure AtPutBtnClick(Sender: TObject);
procedure DelBtnClick(Sender: TObject);
procedure AtDelBtnClick(Sender: TObject);
procedure InsBtnClick(Sender: TObject);
procedure LB1DblClick(Sender: TObject);
procedure LB1Click(Sender: TObject);
procedure SaveBtnClick(Sender: TObject);
procedure LoadBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure SetBusy(B : Boolean);
procedure FillControls(AR : ARecord);
function CheckControls(var AR : ARecord) : Boolean;
procedure FillListBox;
procedure UpdateButtons(COK : Boolean);
end;
var
STDlg: TSTDlg;
implementation
{$R *.lfm}
const
MaxElem = 20000;
var
FirstA : array[0..7] of S10;
LastA : array[0..7] of S15;
MyCollection : TStCollection;
procedure MyDelNodeData(Data : pointer); far;
{-procedure to delete data pointer in each node}
begin
FreeMem(Data,SizeOf(ARecord));
end;
function MatchCollString(Container : TStContainer;
Data : Pointer;
OtherData : Pointer) : Boolean; far;
begin
Result := (ARecord(Data^).First <> ARecord(OtherData^).First) OR
(ARecord(Data^).Last <> ARecord(OtherData^).Last);
end;
function CollWalker(Container : TStContainer;
Data : Pointer;
OtherData : Pointer) : Boolean; far;
{this function makes no comparison and always returns True}
{so it will visit all nodes in the collection}
begin
with ARecord(Data^) do
STDlg.LB1.Items.Add(First + ' ' + Last + ', ' + IntToStr(Age));
Result := True;
end;
procedure MyStoreData(Writer : TWriter; Data : Pointer); far;
begin
with ARecord(Data^), Writer do
begin
WriteString(First);
WriteString(Last);
WriteInteger(Age);
end;
end;
function MyLoadData(Reader : TReader) : Pointer; far;
begin
GetMem(Result,SizeOf(ARecord));
with ARecord(Result^), Reader do
begin
First := ReadString;
Last := ReadString;
Age := ReadInteger;
end;
end;
procedure TSTDlg.UpdateButtons(COK : Boolean);
begin
ClearBtn.Enabled := COK;
PackBtn.Enabled := COK;
AtBtn.Enabled := COK;
AtInsBtn.Enabled := COK;
AtPutBtn.Enabled := COK;
DelBtn.Enabled := COK;
AtDelBtn.Enabled := COK;
InsBtn.Enabled := COK;
EffBtn.Enabled := COK;
SaveBtn.Enabled := COK;
end;
procedure TSTDlg.FormCreate(Sender: TObject);
begin
RegisterClass(TStCollection);
UpdateButtons(False);
FirstA[0] := 'Fred';
FirstA[1] := 'Robert';
FirstA[2] := 'Barney';
FirstA[3] := 'Horatio';
FirstA[4] := 'Kent';
FirstA[5] := 'Arthur';
FirstA[6] := 'Lee';
FirstA[7] := 'John Q. ';
LastA[0] := 'Flintstone';
LastA[1] := 'Java';
LastA[2] := 'Rubble';
LastA[3] := 'Hornblower';
LastA[4] := 'C++Builder';
LastA[5] := 'Miller';
LastA[6] := 'Delphi';
LastA[7] := 'Public';
end;
procedure TSTDlg.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
MyCollection.Free;
end;
procedure TSTDlg.SetBusy(B : Boolean);
begin
if B then
Screen.Cursor := crHourGlass
else
Screen.Cursor := crDefault;
end;
function TSTDlg.CheckControls(var AR : ARecord) : Boolean;
var
C,
IV : Integer;
begin
Result := False;
if (Edit3.Text = '') OR
(Edit4.Text = '') OR
(Edit5.Text = '') then
Exit;
AR.First := Edit3.Text;
AR.Last := Edit4.Text;
Val(Edit5.Text,IV,C);
if (C<>0) then
Exit
else
AR.Age := IV;
Result := True;
end;
procedure TSTDlg.FillControls(AR : ARecord);
begin
with AR do
begin
Edit3.Text := First;
Edit4.Text := Last;
Edit5.Text := IntToStr(Age);
end;
end;
procedure TSTDlg.FillListBox;
begin
LB1.Items.BeginUpdate;
try
SetBusy(True);
MyCollection.Iterate(CollWalker,True,nil);
finally
LB1.Items.EndUpdate;
end;
LB1.ItemIndex := 0;
Edit2.Text := '0';
SetBusy(False);
end;
procedure TSTDlg.CreateBtnClick(Sender: TObject);
var
I : Integer;
AR : ^ARecord;
begin
if Assigned(MyCollection) then
MyCollection.Free;
UpdateButtons(False);
MyCollection := TStCollection.Create(100);
MyCollection.DisposeData := MyDelNodeData;
MyCollection.LoadData := MyLoadData;
MyCollection.StoreData := MyStoreData;
Randomize;
LB1.Items.BeginUpdate;
try
SetBusy(True);
for I := 0 to MaxElem-1 do
begin
GetMem(AR,SizeOf(ARecord));
with AR^ do
begin
First := FirstA[Random(8)];
Last := LastA[Random(8)];
Age := Random(100);
MyCollection.Insert(AR);
LB1.Items.Add(First + ' ' + Last + ', ' + IntToStr(Age));
end;
end;
finally
LB1.Items.EndUpdate;
end;
MyCollection.Pack;
Edit1.Text := IntToStr(MyCollection.Efficiency);
UpdateButtons(True);
SetBusy(False);
end;
procedure TSTDlg.ClearBtnClick(Sender: TObject);
begin
MyCollection.Clear;
LB1.Clear;
Edit1.Text := IntToStr(MyCollection.Efficiency);
end;
procedure TSTDlg.PackBtnClick(Sender: TObject);
begin
if (MessageDlg('Current Efficiency: ' + IntToStr(MyCollection.Efficiency) +
#13 + 'Pack Collection?',
mtConfirmation,[mbYes,mbNo],0) = mrNo) then Exit;
MyCollection.Pack;
Edit1.Text := IntToStr(MyCollection.Efficiency);
end;
procedure TSTDlg.EffBtnClick(Sender: TObject);
begin
Edit1.Text := IntToStr(MyCollection.Efficiency);
end;
procedure TSTDlg.AtBtnClick(Sender: TObject);
var
Data : Pointer;
E : LongInt;
begin
if (Edit2.Text = '') then
Edit2.Text := '0';
E := StrToInt(Edit2.Text);
if (E > MyCollection.Count-1) OR (E < 0) then
begin
ShowMessage('Element value out of range (0..' + IntToStr(MyCollection.Count) + ')');
Edit2.Text := '0';
Exit;
end;
Data := MyCollection.At(E);
FillControls(ARecord(Data^));;
end;
procedure TSTDlg.AtInsBtnClick(Sender: TObject);
var
E : LongInt;
PAR : ^ARecord;
begin
GetMem(PAR,SizeOf(ARecord));
if (NOT CheckControls(PAR^)) then
begin
ShowMessage('One or more data controls invalid');
FreeMem(PAR,SizeOf(ARecord));
Exit;
end;
if (Edit2.Text = '') then
Edit2.Text := '0';
E := StrToInt(Edit2.Text);
if (E > MyCollection.Count-1) OR (E < 0) then
begin
ShowMessage('Element value out of range (0..' + IntToStr(MyCollection.Count) + ')');
Edit2.Text := '0';
Exit;
end;
MyCollection.AtInsert(E,PAR);
FillListBox;
end;
procedure TSTDlg.AtPutBtnClick(Sender: TObject);
var
E : LongInt;
Data : Pointer;
AR : ARecord;
begin
if (NOT CheckControls(AR)) then
begin
ShowMessage('One or more data controls invalid');
Exit;
end;
if (Edit2.Text = '') then
Edit2.Text := '0';
E := StrToInt(Edit2.Text);
if (E > MyCollection.Count-1) OR (E < 0) then
begin
ShowMessage('Element value out of range (0..' + IntToStr(MyCollection.Count) + ')');
Edit2.Text := '0';
Exit;
end;
Data := MyCollection.At(E);
if Data <> nil then
begin
ARecord(Data^) := AR;
MyCollection.AtPut(E, Data);
FillListBox;
end;
end;
procedure TSTDlg.DelBtnClick(Sender: TObject);
var
AR : ARecord;
PN : Pointer;
begin
if (NOT CheckControls(AR)) then
begin
ShowMessage('One or more data entry fields invalid');
Exit;
end;
PN := MyCollection.Iterate(MatchCollString,True,@AR);
if (PN <> nil) then
begin
MyCollection.Delete(PN);
FillListBox;
end else
ShowMessage('Data not found');
end;
procedure TSTDlg.AtDelBtnClick(Sender: TObject);
var
E : LongInt;
begin
if (Edit2.Text = '') then
E := 0
else
E := StrToInt(Edit2.Text);
if (E > MyCollection.Count-1) OR (E < 0) then
begin
ShowMessage('Element value out of range (0..' + IntToStr(MyCollection.Count) + ')');
Edit2.Text := '0';
Exit;
end;
MyCollection.AtDelete(E);
FillListBox;
end;
procedure TSTDlg.InsBtnClick(Sender: TObject);
var
E : Integer;
AR : ^ARecord;
begin
if (Edit2.Text = '') then
E := 0
else
E := StrToInt(Edit2.Text);
if (E > MyCollection.Count-1) OR (E < 0) then
begin
ShowMessage('Element value out of range (0..' + IntToStr(MyCollection.Count) + ')');
Edit2.Text := '0';
Exit;
end;
GetMem(AR,SizeOf(ARecord));
if (NOT CheckControls(AR^)) then
begin
ShowMessage('One or more data entry fields invalid');
FreeMem(AR,SizeOf(ARecord));
Exit;
end;
MyCollection.Insert(AR);
FillListBox;
end;
procedure TSTDlg.LB1DblClick(Sender: TObject);
begin
MyCollection.AtDelete(LB1.ItemIndex);
FillListBox;
Edit2.Text := '0';
end;
procedure TSTDlg.LB1Click(Sender: TObject);
begin
Edit2.Text := IntToStr(LB1.ItemIndex);
end;
procedure TSTDlg.LoadBtnClick(Sender: TObject);
begin
if (OD1.Execute) then
begin
if (NOT Assigned(MyCollection)) then
begin
UpdateButtons(False);
MyCollection := TStCollection.Create(100);
MyCollection.DisposeData := MyDelNodeData;
MyCollection.LoadData := MyLoadData;
MyCollection.StoreData := MyStoreData;
end;
LB1.Clear;
MyCollection.Clear;
SetBusy(True);
MyCollection.LoadFromFile(OD1.FileName);
MyCollection.Pack;
SetBusy(False);
FillListBox;
UpdateButtons(True);
end;
end;
procedure TSTDlg.SaveBtnClick(Sender: TObject);
begin
if (SD1.Execute) then
begin
SetBusy(True);
MyCollection.StoreToFile(SD1.FileName);
SetBusy(False);
end;
end;
end.

84
components/systools/examples/double_ended_queue/exdque.lpi Normal file
View File

@@ -0,0 +1,84 @@
<?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="exdque"/>
<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="exdque.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Exdque"/>
</Unit0>
<Unit1>
<Filename Value="exdqueu.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
<UnitName Value="ExDQueU"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="exdque"/>
</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>

46
components/systools/examples/double_ended_queue/exdque.lpr Normal file
View File

@@ -0,0 +1,46 @@
(* ***** 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 Exdque;
uses
Interfaces,
Forms, lclversion,
exequeu in 'exdqueu.pas' {STDlg};
{$R *.res}
begin
{$IF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TStDlg, StDlg);
Application.Run;
end.

168
components/systools/examples/double_ended_queue/exdqueu.lfm Normal file
View File

@@ -0,0 +1,168 @@
object STDlg: TSTDlg
Left = 273
Top = 156
ActiveControl = CreateBtn
BorderStyle = bsDialog
Caption = 'StDQue Example'
ClientHeight = 274
ClientWidth = 305
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clBlack
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
ShowHint = True
OnClose = FormClose
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object CreateBtn: TButton
Left = 41
Top = 16
Width = 70
Height = 25
Hint = 'Create MyDQue'
Caption = 'Create'
TabOrder = 0
OnClick = CreateBtnClick
end
object Edit1: TEdit
Left = 23
Top = 76
Width = 108
Height = 21
Hint = 'Value?'
MaxLength = 10
TabOrder = 2
end
object PushHeadBtn: TButton
Left = 4
Top = 105
Width = 70
Height = 32
Hint = 'Add to Top'
Caption = 'Push Head'
Enabled = False
TabOrder = 4
OnClick = PushHeadBtnClick
end
object PopHeadBtn: TButton
Left = 82
Top = 104
Width = 70
Height = 32
Hint = 'Remove from Top'
Caption = 'Pop Head'
Enabled = False
ModalResult = 1
TabOrder = 5
OnClick = PopHeadBtnClick
end
object HeadBtn: TButton
Left = 4
Top = 190
Width = 70
Height = 32
Hint = 'Peek Top Item'
Caption = 'Peek Head'
Enabled = False
TabOrder = 8
OnClick = HeadBtnClick
end
object TailBtn: TButton
Left = 82
Top = 190
Width = 70
Height = 32
Hint = 'Peek Last Item'
Caption = 'Peek Tail'
Enabled = False
TabOrder = 9
OnClick = TailBtnClick
end
object LB1: TListBox
Left = 166
Top = 16
Width = 129
Height = 207
TabStop = False
Font.Charset = DEFAULT_CHARSET
Font.Color = clBlack
Font.Height = -12
Font.Name = 'Courier New'
Font.Style = []
ItemHeight = 15
ParentFont = False
TabOrder = 3
end
object LoadBtn: TButton
Left = 168
Top = 233
Width = 58
Height = 30
Hint = 'Load DQue'
Caption = 'Load'
TabOrder = 10
OnClick = LoadBtnClick
end
object SaveBtn: TButton
Left = 236
Top = 233
Width = 58
Height = 30
Hint = 'Save DQue'
Caption = 'Save'
Enabled = False
TabOrder = 11
OnClick = SaveBtnClick
end
object ClearBtn: TButton
Left = 41
Top = 44
Width = 70
Height = 25
Hint = 'Create MyDQue'
Caption = 'Clear'
Enabled = False
TabOrder = 1
OnClick = ClearBtnClick
end
object PushTailBtn: TButton
Left = 4
Top = 148
Width = 70
Height = 32
Hint = 'Add to Bottom'
Caption = 'Push Tail'
Enabled = False
ModalResult = 1
TabOrder = 6
OnClick = PushTailBtnClick
end
object PopTailBtn: TButton
Left = 82
Top = 147
Width = 70
Height = 32
Hint = 'Remove from Bottom'
Caption = 'Pop Tail'
Enabled = False
TabOrder = 7
OnClick = PopTailBtnClick
end
object OD1: TOpenDialog
DefaultExt = 'dqd'
Filter = '*.dqd (DQue data)|*.dqd|*.* (All files)|*.*'
Left = 162
Top = 194
end
object SD1: TSaveDialog
DefaultExt = 'dqd'
Filter = '*.dqd (DQue files)|*.dqd|*.* (All files)|*.*'
Left = 238
Top = 194
end
end

268
components/systools/examples/double_ended_queue/exdqueu.pas Normal file
View File

@@ -0,0 +1,268 @@
(* ***** 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 ExDQueU;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, ExtCtrls,
StConst, StBase, StUtils, StList, StDQue;
type
S10 = string[10];
TSTDlg = class(TForm)
CreateBtn: TButton;
Edit1: TEdit;
PushHeadBtn: TButton;
PopHeadBtn: TButton;
HeadBtn: TButton;
TailBtn: TButton;
LB1: TListBox;
LoadBtn: TButton;
SaveBtn: TButton;
OD1: TOpenDialog;
SD1: TSaveDialog;
ClearBtn: TButton;
PushTailBtn: TButton;
PopTailBtn: TButton;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CreateBtnClick(Sender: TObject);
procedure PushHeadBtnClick(Sender: TObject);
procedure PopHeadBtnClick(Sender: TObject);
procedure HeadBtnClick(Sender: TObject);
procedure TailBtnClick(Sender: TObject);
procedure LoadBtnClick(Sender: TObject);
procedure SaveBtnClick(Sender: TObject);
procedure ClearBtnClick(Sender: TObject);
procedure PushTailBtnClick(Sender: TObject);
procedure PopTailBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
MyDQue : TStDQue;
procedure FillListBox;
procedure UpdateButtons(QueOK : Boolean);
end;
const
MaxElem = 100;
var
STDlg: TSTDlg;
implementation
{$R *.lfm}
procedure MyDelNodeData(Data : pointer); far;
{-procedure to delete data pointer in each node
during call to TSTList.Destroy}
begin
FreeMem(Data, SizeOf(S10));
end;
function MyLoadData(Reader : TReader) : Pointer; far;
begin
GetMem(Result, SizeOf(S10));
S10(Result^) := Reader.ReadString;
end;
procedure MyStoreData(Writer : TWriter; Data : Pointer); far;
begin
Writer.WriteString(S10(Data^));
end;
procedure TSTDlg.FormCreate(Sender: TObject);
begin
RegisterClasses([TStDQue,TStListNode]);
UpdateButtons(False);
end;
procedure TSTDlg.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
MyDQue.Free;
end;
procedure TSTDlg.FillListBox;
var
PN : TStListNode;
begin
LB1.Items.BeginUpdate;
try
PN := MyDQue.Head;
while (PN <> nil) do
begin
LB1.Items.Add(S10(PN.Data^));
PN := MyDQue.Next(PN);
end;
finally
LB1.Items.EndUpdate;
end;
end;
procedure TSTDlg.UpdateButtons(QueOK : Boolean);
begin
ClearBtn.Enabled := QueOK;
PushHeadBtn.Enabled := QueOK;
PopHeadBtn.Enabled := QueOK;
PushTailBtn.Enabled := QueOK;
PopTailBtn.Enabled := QueOK;
HeadBtn.Enabled := QueOK;
TailBtn.Enabled := QueOK;
SaveBtn.Enabled := QueOK;
end;
procedure TSTDlg.CreateBtnClick(Sender: TObject);
var
I : Integer;
S : ^S10;
begin
if Assigned(MyDQue) then
MyDQue.Free;
UpdateButtons(False);
MyDQue := TStDQue.Create(TStListNode);
MyDQue.DisposeData := MyDelNodeData;
MyDQue.LoadData := MyLoadData;
MyDQue.StoreData := MyStoreData;
for I := 1 to MaxElem do
begin
GetMem(S, SizeOf(S10));
S^ := 'Item' + IntToStr(I);
MyDQue.Append(S);
end;
FillListBox;
UpdateButtons(True);
end;
procedure TSTDlg.ClearBtnClick(Sender: TObject);
begin
MyDQue.Clear;
Edit1.Text := '';
FillListBox;
UpdateButtons(False);
end;
procedure TSTDlg.PushHeadBtnClick(Sender: TObject);
var
NewString : ^S10;
begin
if (Edit1.Text = '') then
begin
ShowMessage('No value entered');
Exit;
end;
GetMem(NewString,SizeOf(S10));
NewString^ := Edit1.Text;
MyDQue.PushHead(NewString);
FillListBox;
end;
procedure TSTDlg.PopHeadBtnClick(Sender: TObject);
begin
MyDQue.PopHead;
FillListBox;
end;
procedure TSTDlg.PushTailBtnClick(Sender: TObject);
var
NewString : ^S10;
begin
if (Edit1.Text = '') then
begin
ShowMessage('No value entered');
Exit;
end;
GetMem(NewString,SizeOf(S10));
NewString^ := Edit1.Text;
MyDQue.PushTail(NewString);
FillListBox;
end;
procedure TSTDlg.PopTailBtnClick(Sender: TObject);
begin
MyDQue.PopTail;
FillListBox;
end;
procedure TSTDlg.HeadBtnClick(Sender: TObject);
var
Data : Pointer;
begin
MyDQue.PeekHead(Data);
Edit1.Text := S10(Data^);
end;
procedure TSTDlg.TailBtnClick(Sender: TObject);
var
Data : Pointer;
begin
MyDQue.PeekTail(Data);
Edit1.Text := S10(Data^);
end;
procedure TSTDlg.LoadBtnClick(Sender: TObject);
begin
if (OD1.Execute) then
begin
if (NOT Assigned(MyDQue)) then
begin
UpdateButtons(False);
MyDQue := TStDQue.Create(TStListNode);
MyDQue.DisposeData := MyDelNodeData;
MyDQue.LoadData := MyLoadData;
MyDQue.StoreData := MyStoreData;
end;
MyDQue.LoadFromFile(OD1.FileName);
FillListBox;
UpdateButtons(True);
end;
end;
procedure TSTDlg.SaveBtnClick(Sender: TObject);
begin
if (SD1.Execute) then
MyDQue.StoreToFile(SD1.FileName);
end;
end.

86
components/systools/examples/nonvisual/exnv.lpi Normal file
View File

@@ -0,0 +1,86 @@
<?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="exnv"/>
<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="exnv.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ExNV"/>
</Unit0>
<Unit1>
<Filename Value="exnvu.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="NVForm"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ExNVU"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="exnv"/>
</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>

46
components/systools/examples/nonvisual/exnv.lpr Normal file
View File

@@ -0,0 +1,46 @@
(* ***** 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 ExNV;
uses
Interfaces,
Forms, lclversion,
exnvi in 'exnvu.pas' {NVForm};
{$R *.res}
begin
{$IF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TNVForm, NVForm);
Application.Run;
end.

55
components/systools/examples/nonvisual/exnvu.lfm Normal file
View File

@@ -0,0 +1,55 @@
object NVForm: TNVForm
Left = 266
Height = 178
Top = 190
Width = 418
Caption = 'Non Visual Containter Class Components'
ClientHeight = 178
ClientWidth = 418
Color = clBtnFace
Font.Color = clWindowText
Position = poScreenCenter
LCLVersion = '1.9.0.0'
object Button1: TButton
Left = 328
Height = 25
Top = 8
Width = 75
Caption = 'Bits'
OnClick = Button1Click
TabOrder = 1
end
object Button2: TButton
Left = 328
Height = 25
Top = 48
Width = 75
Caption = 'Dictionary'
OnClick = Button2Click
TabOrder = 2
end
object Memo1: TMemo
Left = 4
Height = 161
Top = 5
Width = 313
TabOrder = 0
end
object Button3: TButton
Left = 328
Height = 25
Top = 142
Width = 75
Caption = 'Close'
OnClick = Button3Click
TabOrder = 3
end
object StNVBits1: TStNVBits
left = 128
top = 40
end
object StNVDictionary1: TStNVDictionary
left = 128
top = 96
end
end

107
components/systools/examples/nonvisual/exnvu.pas Normal file
View File

@@ -0,0 +1,107 @@
(* ***** 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 ExNVU;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
StBase, StNVCont, StNVBits, StNVDict, StNVList, StNVDQ, StNVLAry,
StNVLMat, StNVColl, StNVSCol, StNVTree;
type
TNVForm = class(TForm)
StNVBits1: TStNVBits;
StNVDictionary1: TStNVDictionary;
Button1: TButton;
Button2: TButton;
Memo1: TMemo;
Button3: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
NVForm: TNVForm;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TNVForm.Button1Click(Sender: TObject);
begin
Memo1.Clear;
Memo1.Lines.Add('Initializing bit set to hold 500 bits');
StNVBits1.MaxBits := 500;
Memo1.Lines.Add('Set bit 5');
StNVBits1.Container.SetBit(5);
if StNVBits1.Container.BitIsSet(5) then
Memo1.Lines.Add('bit 5 is set')
else
Memo1.Lines.Add('bit 5 is not set');
Memo1.Lines.Add('Toggle bit 5');
StNVBits1.Container.ToggleBit(5);
if StNVBits1.Container.BitIsSet(5) then
Memo1.Lines.Add('bit 5 is set')
else
Memo1.Lines.Add('bit 5 is not set');
end;
procedure TNVForm.Button3Click(Sender: TObject);
begin
Close;
end;
procedure TNVForm.Button2Click(Sender: TObject);
begin
Memo1.Clear;
Memo1.Lines.Add('Clearing dictionary');
StNVDictionary1.Container.Clear;
Memo1.Lines.Add('Adding items to dictionary');
StNVDictionary1.Container.Add('First', nil);
StNVDictionary1.Container.Add('Second', nil);
StNVDictionary1.Container.Add('Third', nil);
StNVDictionary1.Container.Add('Fourth', nil);
StNVDictionary1.Container.Add('Fifth', nil);
end;
end.

85
components/systools/examples/priority_queue/expq.lpi Normal file
View 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
View 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
View 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
View 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.

86
components/systools/examples/tree/extree.lpi Normal file
View File

@@ -0,0 +1,86 @@
<?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="extree"/>
<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="extree.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Extree"/>
</Unit0>
<Unit1>
<Filename Value="extreeu.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="STDlg"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ExTreeU"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="extree"/>
</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>

46
components/systools/examples/tree/extree.lpr Normal file
View File

@@ -0,0 +1,46 @@
(* ***** 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 Extree;
uses
Interfaces,
Forms, lclversion,
extreeu in 'extreeu.pas' {STDlg};
{$R *.res}
begin
{$IF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TSTDlg, STDlg);
Application.Run;
end.

173
components/systools/examples/tree/extreeu.lfm Normal file
View File

@@ -0,0 +1,173 @@
object STDlg: TSTDlg
Left = 229
Height = 258
Top = 159
Width = 418
ActiveControl = CreateBtn
Caption = 'StTree Example'
ClientHeight = 258
ClientWidth = 418
Color = clBtnFace
Font.Color = clBlack
OnActivate = FormActivate
OnClose = FormClose
OnCreate = FormCreate
Position = poScreenCenter
ShowHint = True
LCLVersion = '1.9.0.0'
object Label1: TLabel
Left = 14
Height = 15
Top = 184
Width = 22
Caption = 'First'
ParentColor = False
end
object Label2: TLabel
Left = 14
Height = 15
Top = 209
Width = 21
Caption = 'Last'
ParentColor = False
end
object Label3: TLabel
Left = 14
Height = 15
Top = 233
Width = 21
Caption = 'Age'
ParentColor = False
end
object CreateBtn: TButton
Left = 12
Height = 33
Hint = 'Create a Tree'
Top = 12
Width = 75
Caption = 'Create'
OnClick = CreateBtnClick
TabOrder = 0
end
object ClearBtn: TButton
Left = 106
Height = 33
Hint = 'Clear Tree'
Top = 12
Width = 75
Caption = 'Clear'
OnClick = ClearBtnClick
TabOrder = 1
end
object LB1: TListBox
Left = 218
Height = 237
Hint = 'DblClk to delete selected item'
Top = 14
Width = 193
ItemHeight = 0
OnDblClick = LB1DblClick
TabOrder = 11
TabStop = False
end
object Edit1: TEdit
Left = 58
Height = 23
Hint = '1 to 10 characters'
Top = 182
Width = 89
MaxLength = 10
TabOrder = 8
end
object Edit2: TEdit
Left = 58
Height = 23
Hint = '1 to 15 characters'
Top = 206
Width = 89
MaxLength = 15
TabOrder = 9
end
object Edit3: TEdit
Left = 58
Height = 23
Hint = '1 to 32627'
Top = 230
Width = 29
MaxLength = 5
TabOrder = 10
end
object InsertBtn: TButton
Left = 12
Height = 33
Hint = 'Insert new record'
Top = 52
Width = 75
Caption = 'Insert'
OnClick = InsertBtnClick
TabOrder = 2
end
object DeleteBtn: TButton
Left = 106
Height = 33
Hint = 'Delete a record'
Top = 52
Width = 75
Caption = 'Delete'
OnClick = DeleteBtnClick
TabOrder = 3
end
object FindBtn: TButton
Left = 12
Height = 33
Hint = 'Find a record'
Top = 94
Width = 75
Caption = 'Find'
OnClick = FindBtnClick
TabOrder = 4
end
object SearchBtn: TButton
Left = 106
Height = 33
Hint = 'Search by last name'
Top = 94
Width = 75
Caption = 'Search'
OnClick = SearchBtnClick
TabOrder = 5
end
object LoadBtn: TButton
Left = 12
Height = 33
Hint = 'Load from disk'
Top = 134
Width = 75
Caption = 'Load'
OnClick = LoadBtnClick
TabOrder = 6
end
object SaveBtn: TButton
Left = 106
Height = 33
Hint = 'Save to disk'
Top = 134
Width = 75
Caption = 'Save'
OnClick = SaveBtnClick
TabOrder = 7
end
object OD1: TOpenDialog
DefaultExt = '.TDF'
Filter = '*.tdf (Tree files)|*.tdf|*.* (All files)|*.*'
left = 288
top = 40
end
object SD1: TSaveDialog
DefaultExt = '.TDF'
Filter = '*.tdf (Tree files)|*.tdf|*.* (All files)|*.*'
Options = [ofOverwritePrompt]
left = 288
top = 120
end
end

452
components/systools/examples/tree/extreeu.pas Normal file
View File

@@ -0,0 +1,452 @@
(* ***** 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 ExTreeU;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls,
StConst, StBase, StTree;
type
S10 = String[10];
S15 = String[15];
PersonRecord = record
First : S10;
Last : S15;
Age : Integer;
end;
PPersonRecord = ^PersonRecord;
TSTDlg = class(TForm)
CreateBtn: TButton;
ClearBtn: TButton;
LB1: TListBox;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
InsertBtn: TButton;
DeleteBtn: TButton;
FindBtn: TButton;
SearchBtn: TButton;
LoadBtn: TButton;
SaveBtn: TButton;
OD1: TOpenDialog;
SD1: TSaveDialog;
procedure FormActivate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CreateBtnClick(Sender: TObject);
procedure ClearBtnClick(Sender: TObject);
procedure InsertBtnClick(Sender: TObject);
procedure DeleteBtnClick(Sender: TObject);
procedure FindBtnClick(Sender: TObject);
procedure SearchBtnClick(Sender: TObject);
procedure LB1DblClick(Sender: TObject);
procedure SaveBtnClick(Sender: TObject);
procedure LoadBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure SetBusy(B : Boolean);
procedure FillListBox;
procedure FillControls(PR : PersonRecord);
function GetControls(var PR : PersonRecord) : Boolean;
procedure UpdateButtons(TOK : Boolean);
end;
const
MaxElem = 3000;
var
STDlg: TSTDlg;
FirstA : array[0..7] of S10;
LastA : array[0..7] of S15;
MyTree : TStTree;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
function MyLoadData(Reader : TReader) : Pointer; far;
begin
GetMem(Result,SizeOf(PersonRecord));
with PersonRecord(Result^), Reader do
begin
First := ReadString;
Last := ReadString;
Age := ReadInteger;
end;
end;
procedure MyStoreData(Writer : TWriter; Data : Pointer); far;
var
PR : PersonRecord;
begin
PR := PersonRecord(Data^);
with Writer do
begin
WriteString(PR.First);
WriteString(PR.Last);
WriteInteger(PR.Age);
end;
end;
procedure MyDisposeData(Data : Pointer); far;
begin
FreeMem(Data, SizeOf(PersonRecord));
end;
function MySortTree(Data1, Data2 : Pointer) : Integer; far;
var
R1 : PPersonRecord absolute Data1;
R2 : PPersonRecord absolute Data2;
begin
Result := CompareText(R1^.Last, R2^.Last);
if Result = 0 then
CompareText(R1^.First, R2^.First);
if Result = 0 then
Result := (R1^.Age - R2^.Age);
end;
function MyTreeWalker(Contariner : TStContainer;
Node : TStNode;
OtherData : Pointer) : Boolean; far;
var
R : PersonRecord;
S : String;
begin
R := PersonRecord(Node.Data^);
S := R.Last + ', ' + R.First + ', ' + IntToStr(R.Age);
STDlg.LB1.Items.Add(S);
Result := True;
end;
function MyTreeSearcher(Contariner : TStContainer;
Node : TStNode;
OtherData : Pointer) : Boolean; far;
var
S : string;
R1 : PersonRecord;
R2 : PPersonRecord absolute OtherData;
begin
R1 := PersonRecord(Node.Data^);
if (CompareText(R1.Last, R2^.Last) = 0) then
begin
S := 'Match: ' + R1.First + ' ' + R1.Last + ', ' + IntToStr(R1.Age);
if MessageDlg(S,mtInformation,[mbOK,mbCancel],0) = mrCancel then
Result := False
else
Result := True;
end else
Result := True;
end;
procedure TSTDlg.SetBusy(B : Boolean);
begin
if B then
Screen.Cursor := crHourGlass
else
Screen.Cursor := crDefault;
end;
procedure TSTDlg.FillListBox;
begin
LB1.Items.BeginUpdate;
try
LB1.Clear;
SetBusy(True);
MyTree.Iterate(MyTreeWalker,True,nil);
finally
LB1.Items.EndUpdate;
end;
SetBusy(False);
end;
procedure TSTDlg.FillControls(PR : PersonRecord);
begin
Edit1.Text := PR.First;
Edit2.Text := PR.Last;
Edit3.Text := IntToStr(PR.Age);
end;
function TSTDlg.GetControls(var PR : PersonRecord) : Boolean;
var
I,
Code : Integer;
begin
Result := False;
if (Edit1.Text = '') OR
(Edit2.Text = '') OR
(Edit3.Text = '') then
Exit;
PR.First := Edit1.Text;
PR.Last := Edit2.Text;
Val(Edit3.Text,I,Code);
if (Code <> 0) then
Exit
else
PR.Age := I;
Result := True;
end;
procedure TSTDlg.UpdateButtons(TOK : Boolean);
begin
ClearBtn.Enabled := TOK;
InsertBtn.Enabled := TOK;
DeleteBtn.Enabled := TOK;
FindBtn.Enabled := TOK;
SearchBtn.Enabled := TOK;
SaveBtn.Enabled := TOK;
end;
procedure TSTDlg.FormCreate(Sender: TObject);
begin
RegisterClasses([TStTree,TStTreeNode]);
UpdateButtons(False);
end;
procedure TSTDlg.FormActivate(Sender: TObject);
begin
FirstA[0] := 'Fred';
FirstA[1] := 'Mike';
FirstA[2] := 'Barney';
FirstA[3] := 'Horatio';
FirstA[4] := 'Mickey';
FirstA[5] := 'Arthur';
FirstA[6] := 'Santa';
FirstA[7] := 'John Q. ';
LastA[0] := 'Flintstone';
LastA[1] := 'Hammer';
LastA[2] := 'Rubble';
LastA[3] := 'Hornblower';
LastA[4] := 'Spilane';
LastA[5] := 'Miller';
LastA[6] := 'Claus';
LastA[7] := 'Public';
end;
procedure TSTDlg.FormClose(Sender: TObject; var Action: TCloseAction);
begin
MyTree.Free;
end;
procedure TSTDlg.CreateBtnClick(Sender: TObject);
var
I : Integer;
PR : PPersonRecord;
TN : TStTreeNode;
begin
if Assigned(MyTree) then
MyTree.Free;
UpdateButtons(False);
MyTree:= TStTree.Create(TStTreeNode);
MyTree.Compare := MySortTree;
MyTree.DisposeData := MyDisposeData;
MyTree.LoadData := MyLoadData;
MyTree.StoreData := MyStoreData;
SetBusy(True);
for I := 0 to MaxElem-1 do
begin
if (I mod 250 = 0) then Randomize;
GetMem(PR, SizeOf(PersonRecord));
with PR^ do
repeat
First := FirstA[Random(8)];
Last := LastA[Random(8)];
Age := Random(10000);
{search for duplicate entry, if found - don't try to add}
TN := MyTree.Find(PR);
if TN = nil then
MyTree.Insert(PR);
until TN = nil;
end;
FillListBox;
SetBusy(False);
UpdateButtons(True);
end;
procedure TSTDlg.ClearBtnClick(Sender: TObject);
begin
MyTree.Clear;
LB1.Clear;
Edit1.Text := '';
Edit2.Text := '';
Edit3.Text := '';
end;
procedure TSTDlg.InsertBtnClick(Sender: TObject);
var
PR : PPersonRecord;
begin
GetMem(PR, SizeOf(PersonRecord));
if NOT (GetControls(PR^)) then
begin
FreeMem(PR, SizeOf(PersonRecord));
ShowMessage('One or more fields invalid');
Exit;
end else
begin
MyTree.Insert(PR);
FillListBox;
end;
end;
procedure TSTDlg.DeleteBtnClick(Sender: TObject);
var
PR : PersonRecord;
TN : TStTreeNode;
begin
if NOT (GetControls(PR)) then
begin
ShowMessage('One or more invalid entry fields');
Exit;
end;
TN := MyTree.Find(@PR);
if (TN <> nil) then
begin
MyTree.Delete(@PR);
FillListBox;
end else
ShowMessage('Record not found');
end;
procedure TSTDlg.FindBtnClick(Sender: TObject);
var
PR : PersonRecord;
TN : TStTreeNode;
begin
if NOT (GetControls(PR)) then
begin
ShowMessage('One or more invalid entry fields');
Exit;
end;
TN := MyTree.Find(@PR);
if (TN <> nil) then
ShowMessage('Record was found');
end;
procedure TSTDlg.SearchBtnClick(Sender: TObject);
var
PR : PersonRecord;
begin
PR.Last := Edit2.Text;
MyTree.Iterate(MyTreeSearcher, True, @PR);
end;
procedure TSTDlg.LB1DblClick(Sender: TObject);
var
I,
L : Integer;
PR : PersonRecord;
S : string;
TN : TStTreeNode;
begin
S := LB1.Items[LB1.ItemIndex];
L := Length(S);
I := pos(',', S);
PR.Last := S;
Delete(PR.Last, I, L-I+1);
Delete(S, 1, I+1);
PR.First := S;
L := Length(PR.First);
I := pos(',', PR.First);
Delete(PR.First, I, L-I+1);
Delete(S, 1, I+1);
PR.Age := StrToInt(S);
TN := MyTree.Find(@PR);
if TN <> nil then
begin
MyTree.Delete(@PR);
FillListBox;
end;
end;
procedure TSTDlg.LoadBtnClick(Sender: TObject);
begin
if OD1.Execute then
begin
if (NOT Assigned(MyTree)) then
begin
UpdateButtons(False);
MyTree:= TStTree.Create(TStTreeNode);
MyTree.Compare := MySortTree;
MyTree.DisposeData := MyDisposeData;
MyTree.LoadData := MyLoadData;
MyTree.StoreData := MyStoreData;
end;
MyTree.Clear;
MyTree.LoadFromFile(OD1.FileName);
FillListBox;
UpdateButtons(True);
end;
end;
procedure TSTDlg.SaveBtnClick(Sender: TObject);
begin
if SD1.Execute then
MyTree.StoreToFile(SD1.FileName);
end;
end.

86
components/systools/examples/virtual_matrix/exvarr.lpi Normal file
View File

@@ -0,0 +1,86 @@
<?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="exvarr"/>
<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="exvarr.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Exvarr"/>
</Unit0>
<Unit1>
<Filename Value="exvarru.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="STDlg"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ExVarrU"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="exvarr"/>
</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/virtual_matrix/exvarr.lpr Normal file
View 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 Exvarr;
uses
Interfaces,
Forms, lclversion,
exvarru in 'exvarru.pas' {STDlg};
{$R *.res}
begin
Application.Scaled := True;
Application.Initialize;
Application.CreateForm(TSTDlg, STDlg);
Application.Run;
end.

162
components/systools/examples/virtual_matrix/exvarru.lfm Normal file
View File

@@ -0,0 +1,162 @@
object STDlg: TSTDlg
Left = 296
Height = 287
Top = 163
Width = 376
BorderStyle = bsDialog
Caption = 'Virtual Matrix (StVMatrix) Example'
ClientHeight = 287
ClientWidth = 376
Color = clBtnFace
Font.Color = clBlack
OnClose = FormClose
OnCreate = FormCreate
Position = poScreenCenter
ShowHint = True
LCLVersion = '1.9.0.0'
object Label6: TLabel
Left = 6
Height = 15
Top = 54
Width = 46
Caption = 'Row/Col'
ParentColor = False
end
object Label3: TLabel
Left = 6
Height = 15
Top = 109
Width = 37
Caption = 'Value 1'
ParentColor = False
end
object Label4: TLabel
Left = 6
Height = 15
Top = 149
Width = 37
Caption = 'Value 2'
ParentColor = False
end
object ArrayLB: TListBox
Left = 228
Height = 267
Top = 10
Width = 135
ItemHeight = 0
TabOrder = 12
end
object CreateBtn: TButton
Left = 54
Height = 30
Hint = 'Create 2d array'
Top = 9
Width = 67
Caption = 'Create VM'
OnClick = CreateBtnClick
TabOrder = 0
end
object VMRow: TEdit
Left = 62
Height = 23
Hint = 'Row?'
Top = 50
Width = 37
TabOrder = 1
Text = '0'
end
object VMCol: TEdit
Left = 106
Height = 23
Hint = 'Column?'
Top = 50
Width = 37
TabOrder = 2
Text = '0'
end
object ClearBtn: TButton
Left = 158
Height = 30
Hint = 'Clear array'
Top = 12
Width = 61
Caption = 'Clear'
OnClick = ClearBtnClick
TabOrder = 9
end
object FillBtn: TButton
Left = 158
Height = 30
Hint = 'Fill array with Value'
Top = 80
Width = 61
Caption = 'Fill'
OnClick = FillBtnClick
TabOrder = 10
end
object PutBtn: TButton
Left = 4
Height = 30
Hint = 'Edit Value'
Top = 209
Width = 61
Caption = 'Put'
OnClick = PutBtnClick
TabOrder = 5
end
object PutRowBtn: TButton
Left = 79
Height = 30
Hint = 'Set values in row to Value'
Top = 209
Width = 61
Caption = 'Put Row'
OnClick = PutRowBtnClick
TabOrder = 6
end
object GetBtn: TButton
Left = 4
Height = 30
Hint = 'Get Value'
Top = 243
Width = 61
Caption = 'Get'
OnClick = GetBtnClick
TabOrder = 7
end
object GetRowBtn: TButton
Left = 78
Height = 30
Hint = 'Get values in row'
Top = 243
Width = 61
Caption = 'Get Row'
OnClick = GetRowBtnClick
TabOrder = 8
end
object SortBtn: TButton
Left = 158
Height = 30
Hint = 'Sort array'
Top = 143
Width = 61
Caption = 'Sort'
OnClick = SortBtnClick
TabOrder = 11
end
object Edit1: TEdit
Left = 50
Height = 23
Top = 105
Width = 87
MaxLength = 6
TabOrder = 3
end
object Edit2: TEdit
Left = 50
Height = 23
Top = 144
Width = 87
TabOrder = 4
end
end

556
components/systools/examples/virtual_matrix/exvarru.pas Normal file
View File

@@ -0,0 +1,556 @@
(* ***** 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 ExVarrU;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, ExtCtrls,
StConst, StBase, StUtils, StVArr;
type
ARecord = record
X, Y : LongInt;
end;
TMyVMatrix = class(TStVMatrix)
protected
Header : array[0..1023] of char;
public
constructor Create(Rows, Cols, ElementSize : Cardinal;
CacheRows : Integer;
const DataFile : string; OpenMode : Word); override;
function HeaderSize : LongInt; override;
procedure ReadHeader; override;
procedure WriteHeader; override;
end;
TSTDlg = class(TForm)
ArrayLB: TListBox;
CreateBtn: TButton;
Label6: TLabel;
VMRow: TEdit;
VMCol: TEdit;
ClearBtn: TButton;
FillBtn: TButton;
PutBtn: TButton;
PutRowBtn: TButton;
GetBtn: TButton;
GetRowBtn: TButton;
SortBtn: TButton;
Label3: TLabel;
Label4: TLabel;
Edit1: TEdit;
Edit2: TEdit;
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 PutRowBtnClick(Sender: TObject);
procedure GetRowBtnClick(Sender: TObject);
procedure SortBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure SetBusy(B : Boolean);
procedure FillListBox;
procedure FillControls;
function GetControls(var AR : ARecord) : Boolean;
function ValidateRowCol(var R, C : LongInt) : Boolean;
procedure UpdateButtons(AOK : Boolean);
end;
var
STDlg: TSTDlg;
ARec : ARecord;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.DFM}
{$ENDIF}
{ File and Share modes
fmOpenRead = $0000;
fmOpenWrite = $0001;
fmOpenReadWrite = $0002;
fmShareCompat = $0000;
fmShareExclusive = $0010;
fmShareDenyWrite = $0020;
fmShareDenyRead = $0030;
fmShareDenyNone = $0040;
}
type
S10 = string[10];
const
MaxRows = 1000;
MaxCols = 10;
RowsCached = 10;
FN = 'MyCache.DAT';
var
MyVMatrix : TMyVMatrix;
RowArray : array[1..MaxCols] of ARecord;
function MyArraySort(const E1, E2) : Integer; far;
var
R1 : ARecord absolute E1;
R2 : ARecord absolute E2;
begin
Result := R1.X-R2.X;
if Result = 0 then
Result := R1.Y-R2.Y;
end;
{ ========== Descendant TMyVMatrix methods =================}
constructor TMyVMatrix.Create(Rows, Cols, ElementSize : Cardinal;
CacheRows : Integer;
const DataFile : string; OpenMode : Word);
begin
strcopy(Header,'DataFile1. Contains data stored in a 2D virtual array');
inherited Create(Rows, Cols, ElementSize, CacheRows, DataFile, OpenMode);
end;
procedure TMyVMatrix.WriteHeader;
begin
FileWrite(vmDataF,Header,SizeOf(Header));
end;
function TMyVMatrix.HeaderSize : LongInt;
begin
Result := SizeOf(Header);
end;
procedure TMyVMatrix.ReadHeader;
begin
FillChar(Header,SizeOf(Header),#0);
FileRead(vmDataF,Header,SizeOf(Header));
end;
{ ================= Form methods ==========================}
procedure TSTDlg.FormCreate(Sender: TObject);
begin
UpdateButtons(False);
end;
procedure TSTDlg.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
MyVMatrix.Free;
end;
procedure TSTDlg.SetBusy(B : Boolean);
begin
if B then
Screen.Cursor := crHourGlass
else
Screen.Cursor := crDefault;
end;
procedure TSTDlg.UpdateButtons(AOK : Boolean);
begin
ClearBtn.Enabled := AOK;
FillBtn.Enabled := AOK;
SortBtn.Enabled := AOK;
PutBtn.Enabled := AOK;
PutRowBtn.Enabled := AOK;
GetBtn.Enabled := AOK;
GetRowBtn.Enabled := AOK;
end;
procedure TSTDlg.FillListBox;
var
row, col : LongInt;
begin
ArrayLB.Items.BeginUpdate;
try
SetBusy(True);
for row := 0 to MaxRows-1 do
begin
for col := 0 to MaxCols-1 do
begin
MyVMatrix.Get(Row,Col,ARec);
ArrayLB.Items.Add(IntToStr(row) + ',' +
IntToStr(col) + ': X = ' +
IntToStr(ARec.X) + ' Y = ' +
IntToStr(ARec.Y));
end;
end;
finally
ArrayLB.Items.EndUpdate;
end;
end;
procedure TSTDlg.FillControls;
begin
with ARec do
begin
Edit1.Text := IntToStr(X);
Edit2.Text := IntToStr(Y);
end;
end;
function TSTDlg.GetControls(var AR : ARecord) : Boolean;
var
Code : Integer;
IV : LongInt;
begin
Result := False;
if (Edit1.Text = '') OR (Edit2.Text = '') then
begin
ShowMessage('One or more blank fields');
Exit;
end;
FillChar(AR,SizeOf(AR),#0);
Val(Edit1.Text,IV,Code);
if (Code <> 0) then
begin
ShowMessage('Illegal entry for X');
Exit;
end else
AR.X := IV;
Val(Edit2.Text,IV,Code);
if (Code <> 0) then
begin
ShowMessage('Illegal entry for Y');
Exit;
end else
AR.Y := IV;
Result := True;
end;
function TSTDlg.ValidateRowCol(var R,C : LongInt) : Boolean;
var
Code : Integer;
Value : LongInt;
begin
Result := False;
if (VMRow.Text = '') then
VMRow.Text := '0';
if (VMCol.Text = '') then
VMCol.Text := '0';
Val(VMRow.Text,Value,Code);
if (Code <> 0) then
begin
ShowMessage('Invalid row entry');
Exit;
end else
begin
if (Value < 0) or (Value > MaxRows-1) then
begin
ShowMessage('Row value out of range');
Exit;
end else
R := Value;
end;
Val(VMCol.Text,Value,Code);
if (Code <> 0) then
begin
ShowMessage('Invalid Col entry');
Exit;
end else
begin
if (Value < 0) or (Value > MaxCols-1) then
begin
ShowMessage('Col value out of range');
Exit;
end else
C := Value;
end;
Result := True;
end;
procedure TSTDlg.CreateBtnClick(Sender: TObject);
var
row,
col : LongInt;
begin
ArrayLB.Clear;
if (MyVMatrix <> nil) then
MyVMatrix.Free;
MyVMatrix := TMyVMatrix.Create(MaxRows,MaxCols,sizeof(ARecord),RowsCached,
FN,fmOpenReadWrite);
if (NOT Assigned(MyVMatrix)) then
begin
ShowMessage('Failed to create Matrix');
UpdateButtons(False);
Exit;
end;
SetBusy(True);
Randomize;
for row := 0 to MaxRows-1 do
begin
for col := 0 to MaxCols-1 do
begin
with ARec do
begin
X := Random(1000);
Y := Random(1000);
MyVMatrix.Put(Row,Col,ARec);
end;
end;
end;
FillListBox;
VMRow.Text := '0';
VMCol.Text := '0';
MyVMatrix.Get(0,0,ARec);
FillControls;
UpdateButtons(True);
SetBusy(False);
end;
procedure TSTDlg.ClearBtnClick(Sender: TObject);
begin
MyVMatrix.Clear;
ArrayLB.Clear;
VMRow.Text := '0';
VMCol.Text := '0';
MyVMatrix.Get(0,0,ARec);
FillControls;
end;
procedure TSTDlg.FillBtnClick(Sender: TObject);
begin
if NOT GetControls(ARec) then
Exit;
MyVMatrix.Fill(ARec);
FillListBox;
VMRow.Text := '0';
VMCol.Text := '0';
MyVMatrix.Get(0, 0, ARec);
FillControls;
SetBusy(False);
end;
procedure TSTDlg.PutBtnClick(Sender: TObject);
var
Code,
Row,
Col : LongInt;
begin
if NOT GetControls(ARec) then
Exit;
if NOT ValidateRowCol(Row,Col) then
Exit;
MyVMatrix.Put(Row,Col,ARec);
Code := (Row * MaxRows) + Col;
ArrayLB.Items[Code] := IntToStr(row) + ',' +
IntToStr(col) + ': X = ' +
IntToStr(ARec.X) + ' Y = ' +
IntToStr(ARec.Y);
MyVMatrix.Get(Row, Col, ARec);
FillControls;
end;
procedure TSTDlg.GetBtnClick(Sender: TObject);
var
row,
col : LongInt;
begin
if NOT ValidateRowCol(Row,Col) then
Exit;
MyVMatrix.Get(Row,Col,ARec);
FillControls;
end;
procedure TSTDlg.PutRowBtnClick(Sender: TObject);
var
Code : Integer;
row,
step,
Value : LongInt;
begin
if NOT GetControls(ARec) then
Exit;
if (VMRow.Text = '') then
VMRow.Text := '0';
Val(VMRow.Text,Value,Code);
if (Code <> 0) then
begin
ShowMessage('Invalid Row Entry');
Exit;
end else
begin
if (Value < 0) OR (Value >= MaxRows) then
begin
ShowMessage('Row out of range');
Exit;
end else
Row := Value;
end;
FillStruct(RowArray,MaxCols,ARec,SizeOf(ARec));
MyVMatrix.PutRow(Row,RowArray);
ArrayLB.Items.BeginUpdate;
try
for step := 1 to MaxCols do
ArrayLB.Items.Add(IntToStr(row) + ',' +
IntToStr(step) + ': X = ' +
IntToStr(ARec.X) + ' Y = ' +
IntToStr(ARec.Y));
finally
ArrayLB.Items.EndUpdate;
end;
MyVMatrix.Get(Row, 0, ARec);
FillControls;
SetBusy(False);
end;
procedure TSTDlg.GetRowBtnClick(Sender: TObject);
var
Code : Integer;
Row,
step,
Value : LongInt;
begin
if (VMRow.Text = '') then
VMRow.Text := '0';
Val(VMRow.Text,Value,Code);
if (Code <> 0) then
begin
ShowMessage('Invalid Row Entry');
Exit;
end else
begin
if (Value < 0) OR (Value >= MaxRows) then
begin
ShowMessage('Row out of range');
Exit;
end else
Row := Value;
end;
FillChar(ARec,SizeOf(ARec),#0);
FillStruct(RowArray,MaxCols,ARec,SizeOf(ARec));
MyVMatrix.GetRow(Row,RowArray);
ArrayLB.Items.BeginUpdate;
try
ArrayLB.Clear;
for step := 1 to MaxCols do
ArrayLB.Items.Add(IntToStr(row) + ',' +
IntToStr(step) + ': X = ' +
IntToStr(ARec.X) + ' Y = ' +
IntToStr(ARec.Y));
MyVMatrix.Get(Row, 0, ARec);
FillControls;
finally
ArrayLB.Items.EndUpdate;
end;
end;
procedure TSTDlg.SortBtnClick(Sender: TObject);
var
row,
col : LongInt;
begin
SetBusy(True);
MyVMatrix.SortRows(0,MyArraySort);
ArrayLB.Items.BeginUpdate;
try
ArrayLB.Clear;
col := 0;
for row := 0 to MaxRows-1 do
begin
MyVMatrix.Get(row,col,ARec);
ArrayLB.Items.Add(IntToStr(row) + ',' +
IntToStr(col) + ': X = ' +
IntToStr(ARec.X) + ' Y = ' +
IntToStr(ARec.Y));
end;
finally
ArrayLB.Items.EndUpdate;
end;
SetBusy(False);
end;
end.