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.

66
components/systools/laz_systools.lpk
View File

@ -16,7 +16,7 @@
<Description Value="Lazarus port of TurboPower SysTools (Delphi version at https://sourceforge.net/projects/tpsystools/) - runtime package"/>
<License Value="MPL 1.1"/>
<Version Major="4" Release="4"/>
<Files Count="40">
<Files Count="56">
<Item1>
<Filename Value="source\run\stbarc.pas"/>
<UnitName Value="StBarC"/>
@ -177,6 +177,70 @@
<Filename Value="source\run\stjupsat.pas"/>
<UnitName Value="StJupsat"/>
</Item40>
<Item41>
<Filename Value="source\run\stbits.pas"/>
<UnitName Value="StBits"/>
</Item41>
<Item42>
<Filename Value="source\run\stcoll.pas"/>
<UnitName Value="StColl"/>
</Item42>
<Item43>
<Filename Value="source\run\stdque.pas"/>
<UnitName Value="StDQue"/>
</Item43>
<Item44>
<Filename Value="source\run\stvarr.pas"/>
<UnitName Value="StVArr"/>
</Item44>
<Item45>
<Filename Value="source\run\stpqueue.pas"/>
<UnitName Value="StPQueue"/>
</Item45>
<Item46>
<Filename Value="source\run\sttree.pas"/>
<UnitName Value="StTree"/>
</Item46>
<Item47>
<Filename Value="source\run\stnvcont.pas"/>
<UnitName Value="StNVCont"/>
</Item47>
<Item48>
<Filename Value="source\run\stnvtree.pas"/>
<UnitName Value="StNVTree"/>
</Item48>
<Item49>
<Filename Value="source\run\stnvbits.pas"/>
<UnitName Value="StNVBits"/>
</Item49>
<Item50>
<Filename Value="source\run\stnvcoll.pas"/>
<UnitName Value="StNVColl"/>
</Item50>
<Item51>
<Filename Value="source\run\stnvdict.pas"/>
<UnitName Value="StNVDict"/>
</Item51>
<Item52>
<Filename Value="source\run\stnvdq.pas"/>
<UnitName Value="StNVDQ"/>
</Item52>
<Item53>
<Filename Value="source\run\stnvlary.pas"/>
<UnitName Value="StNVLAry"/>
</Item53>
<Item54>
<Filename Value="source\run\stnvlist.pas"/>
<UnitName Value="StNVList"/>
</Item54>
<Item55>
<Filename Value="source\run\stnvlmat.pas"/>
<UnitName Value="StNVLMat"/>
</Item55>
<Item56>
<Filename Value="source\run\stnvscol.pas"/>
<UnitName Value="StNVSCol"/>
</Item56>
</Files>
<RequiredPkgs Count="2">
<Item1>

4
components/systools/laz_systools.pas
View File

@ -12,7 +12,9 @@ uses
StHASH, StToHTML, StStrms, StDict, StIniStm, StDecMth, StExpr, StMath,
StFIN, StDateSt, StMoney, StRandom, StStat, StLArr, StBCD, StRegEx, StStrS,
StAstro, StEclpse, StList, StMerc, StAstroP, StVenus, StMars, StJup,
StSaturn, StUranus, StNeptun, StPluto, StJupsat;
StSaturn, StUranus, StNeptun, StPluto, StJupsat, StBits, StColl, StDQue,
StVArr, StPQueue, StTree, StNVCont, StNVTree, StNVBits, StNVColl, StNVDict,
StNVDQ, StNVLAry, StNVList, StNVLMat, StNVSCol;
implementation

16
components/systools/source/design/StReg.pas
View File

@ -67,6 +67,7 @@ uses
StNetCon,
StNetMsg,
StNetPfm,
*)
StNVBits,
StNVColl,
StNVDict,
@ -76,7 +77,6 @@ uses
StNVLMat,
StNVSCol,
StNVTree,
*)
StRegEx,
(*
StSpawn,
@ -92,18 +92,14 @@ uses
StAstro,
StAstroP,
StBCD,
(*
StBits,
StColl,
*)
StConst,
StCrc,
StDate,
StDateSt,
(*
StDict,
StDQue,
*)
StEclpse,
StExpr,
StFIN,
@ -129,8 +125,8 @@ uses
StOStr,
*)
StPluto,
(*
StPQueue,
(*
StRegIni,
*)
StSaturn,
@ -145,13 +141,11 @@ uses
StStrW,
StStrZ,
StText,
StTree,
*)
StTree,
StUranus,
StUtils,
(*
StVArr,
*)
StVenus,
{ new units in ver 4: }
StIniStm,
@ -235,9 +229,8 @@ begin
}
]);
(*
{non-visual container class components}
RegisterComponents('SysTools (CC)',
RegisterComponents('SysTools',
[TStNVBits,
TStNVCollection,
TStNVDictionary,
@ -247,7 +240,6 @@ begin
TStNVLMatrix,
TStNVSortedCollection,
TStNVTree]);
*)
end;
end.

818
components/systools/source/run/stbits.pas Normal file
View File

@ -0,0 +1,818 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StBits.pas 4.04 *}
{*********************************************************}
{* SysTools: Bit set class *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
{Notes:
CopyBits, OrBits, AndBits, and SubBits require that the parameter B have
the same Max value as the current object, or an exception is generated.
Use the inherited Count property to get the number of bits currently set.
TStBits takes advantage of the suballocator whenever the bit set is
small enough to allow it. Changing the Max property of the class
allocates a new data area, copies the old data into it, and then
deallocates the old data area.
Supports up to 2**34 bits, if they will fit into memory.
When Windows 3.1 is used, it requires enhanced mode operation.
}
unit StBits;
interface
uses
Windows, Classes, SysUtils,
StBase, StConst;
type
TStBits = class;
TBitIterateFunc =
function(Container : TStBits; N : LongInt; OtherData : Pointer) : Boolean;
TStBits = class(TStContainer)
{.Z+}
protected
{property instance variables}
FMax : LongInt; {highest element number}
{private instance variables}
btBlockSize : LongInt; {bytes allocated to data area}
btBits : PByte; {pointer to data area}
{undocumented protected methods}
procedure btSetMax(Max : LongInt);
procedure btRecount;
function btByte(I : LongInt) : PByte;
{.Z-}
public
constructor Create(Max : LongInt); virtual;
{-Initialize an empty bitset with highest element number Max}
destructor Destroy; override;
{-Free a bitset}
procedure LoadFromStream(S : TStream); override;
{-Read a bitset from a stream}
procedure StoreToStream(S : TStream); override;
{-Write a bitset to a stream}
procedure Clear; override;
{-Clear all bits in set but leave instance intact}
procedure CopyBits(B : TStBits);
{-Copy all bits in B to this bitset}
procedure SetBits;
{-Set all bits}
procedure InvertBits;
{-Invert all bits}
procedure OrBits(B : TStBits);
{-Or the specified bitset into this one (create the union)}
procedure AndBits(B : TStBits);
{-And the specified bitset with this one (create the intersection)}
procedure SubBits(B : TStBits);
{-Subtract the specified bitset from this one (create the difference)}
procedure SetBit(N : LongInt);
{-Set bit N}
procedure ClearBit(N : LongInt);
{-Clear bit N}
procedure ToggleBit(N : LongInt);
{-Toggle bit N}
procedure ControlBit(N : LongInt; State : Boolean);
{-Set or clear bit N according to State}
function BitIsSet(N : LongInt) : Boolean;
{-Return True if bit N is set}
function FirstSet : LongInt;
{-Return the index of the first set bit, -1 if none}
function LastSet : LongInt;
{-Return the index of the last set bit, -1 if none}
function FirstClear : LongInt;
{-Return the index of the first clear bit, -1 if none}
function LastClear : LongInt;
{-Return the index of the last clear bit, -1 if none}
function NextSet(N : LongInt) : LongInt;
{-Return the index of the next set bit after N, -1 if none}
function PrevSet(N : LongInt) : LongInt;
{-Return the index of the previous set bit after N, -1 if none}
function NextClear(N : LongInt) : LongInt;
{-Return the index of the next set bit after N, -1 if none}
function PrevClear(N : LongInt) : LongInt;
{-Return the index of the previous set bit after N, -1 if none}
function Iterate(Action : TBitIterateFunc;
UseSetBits, Up : Boolean;
OtherData : Pointer) : LongInt;
{-Call Action for all the matching bits, returning the last bit visited}
function IterateFrom(Action : TBitIterateFunc;
UseSetBits, Up : Boolean;
OtherData : Pointer;
From : LongInt) : LongInt;
{-Call Action for all the matching bits starting with bit From}
property Max : LongInt
{-Read or write the maximum element count in the bitset}
read FMax
write btSetMax;
property Items[N : LongInt] : Boolean
{-Read or write Nth bit in set}
read BitIsSet
write ControlBit;
default;
end;
{======================================================================}
implementation
{$IFDEF ThreadSafe}
var
ClassCritSect : TRTLCriticalSection;
{$ENDIF}
procedure EnterClassCS;
begin
{$IFDEF ThreadSafe}
EnterCriticalSection(ClassCritSect);
{$ENDIF}
end;
procedure LeaveClassCS;
begin
{$IFDEF ThreadSafe}
LeaveCriticalSection(ClassCritSect);
{$ENDIF}
end;
function MinLong(A, B : LongInt) : LongInt;
begin
if A < B then
Result := A
else
Result := B;
end;
function MaxLong(A, B : LongInt) : LongInt;
begin
if A > B then
Result := A
else
Result := B;
end;
{----------------------------------------------------------------------}
procedure TStBits.AndBits(B : TStBits);
var
I : LongInt;
P : PByte;
begin
{$IFDEF ThreadSafe}
EnterClassCS;
EnterCS;
B.EnterCS;
try
{$ENDIF}
if (not Assigned(B)) or (B.Max <> FMax) then
RaiseContainerError(stscBadType);
for I := 0 to btBlockSize-1 do begin
P := btByte(I);
P^ := P^ and B.btByte(I)^;
end;
btRecount;
{$IFDEF ThreadSafe}
finally
B.LeaveCS;
LeaveCS;
LeaveClassCS;
end;
{$ENDIF}
end;
function TStBits.BitIsSet(N : LongInt) : Boolean;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{$IFOPT R+}
if (N < 0) or (N > FMax) then
RaiseContainerError(stscBadIndex);
{$ENDIF}
Result := (btByte(N shr 3)^ and (1 shl (Byte(N) and 7)) <> 0);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStBits.btByte(I : LongInt) : PByte;
begin
Result := PByte(PAnsiChar(btBits)+I);
end;
procedure TStBits.btRecount;
const
{number of bits set in every possible byte}
BitCount : array[Byte] of Byte = (
0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4,
1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
4, 5, 5, 6, 5, 6, 6, 7, 5, 6, 6, 7, 6, 7, 7, 8);
var
N : LongInt;
P : PByte;
B : Byte;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{Clear unused bits in last byte}
B := Byte(FMax) and 7;
if B < 7 then begin
P := btByte(btBlockSize-1);
P^ := P^ and ((1 shl (B+1))-1);
end;
{Add up the bits in each byte}
FCount := 0;
for N := 0 to btBlockSize-1 do
inc(FCount, BitCount[btByte(N)^]);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStBits.btSetMax(Max : LongInt);
var
BlockSize, OldBlockSize, OldMax : LongInt;
OldBits : PByte;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{Validate new size}
if Max < 0 then
RaiseContainerError(stscBadSize);
BlockSize := (Max+8) div 8;
{Save old size settings}
OldBlockSize := btBlockSize;
OldMax := FMax;
{Assign new size settings}
FMax := Max;
btBlockSize := BlockSize;
if BlockSize <> OldBlockSize then begin
{Get new data area and transfer data}
OldBits := btBits;
try
HugeGetMem(Pointer(btBits), btBlockSize);
except
btBlockSize := OldBlockSize;
btBits := OldBits;
FMax := OldMax;
raise;
end;
if OldBlockSize < btBlockSize then begin
HugeFillChar(btByte(OldBlockSize)^, btBlockSize-OldBlockSize, 0);
BlockSize := OldBlockSize;
end else
BlockSize := btBlockSize;
HugeMove(OldBits^, btBits^, BlockSize);
{Free old data area}
HugeFreeMem(Pointer(OldBits), OldBlockSize);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStBits.Clear;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
HugeFillChar(btBits^, btBlockSize, 0);
FCount := 0;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStBits.ClearBit(N : LongInt);
var
P : PByte;
M : Byte;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{$IFOPT R+}
if (N < 0) or (N > FMax) then
RaiseContainerError(stscBadIndex);
{$ENDIF}
P := btByte(N shr 3);
M := 1 shl (Byte(N) and 7);
if (P^ and M) <> 0 then begin
P^ := P^ and not M;
dec(FCount);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStBits.ControlBit(N : LongInt; State : Boolean);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if State then
SetBit(N)
else
ClearBit(N);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStBits.CopyBits(B : TStBits);
begin
{$IFDEF ThreadSafe}
EnterClassCS;
EnterCS;
B.EnterCS;
try
{$ENDIF}
if (not Assigned(B)) or (B.Max <> FMax) then
RaiseContainerError(stscBadType);
HugeMove(B.btBits^, btBits^, btBlockSize);
FCount := B.FCount;
{$IFDEF ThreadSafe}
finally
B.LeaveCS;
LeaveCS;
LeaveClassCS;
end;
{$ENDIF}
end;
constructor TStBits.Create(Max : LongInt);
begin
{Validate size}
if Max < 0 then
RaiseContainerError(stscBadSize);
CreateContainer(TStNode, 0);
FMax := Max;
btBlockSize := (Max+8) div 8;
HugeGetMem(Pointer(btBits), btBlockSize);
Clear;
end;
destructor TStBits.Destroy;
begin
if Assigned(btBits) then
HugeFreeMem(Pointer(btBits), btBlockSize);
{Prevent calling Clear}
IncNodeProtection;
inherited Destroy;
end;
function StopImmediately(Container : TStBits; N : LongInt;
OtherData : Pointer) : Boolean; far;
{-Iterator function used to stop after first found bit}
begin
Result := False;
end;
function TStBits.FirstClear : LongInt;
begin
Result := IterateFrom(StopImmediately, False, True, nil, 0);
end;
function TStBits.FirstSet : LongInt;
begin
Result := IterateFrom(StopImmediately, True, True, nil, 0);
end;
procedure TStBits.InvertBits;
var
I : LongInt;
P : PByte;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
for I := 0 to btBlockSize-1 do begin
P := btByte(I);
P^ := not P^;
end;
FCount := FMax-FCount+1;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStBits.Iterate(Action : TBitIterateFunc;
UseSetBits, Up : Boolean;
OtherData : Pointer) : LongInt;
begin
if Up then
Result := IterateFrom(Action, UseSetBits, True, OtherData, 0)
else
Result := IterateFrom(Action, UseSetBits, False, OtherData, FMax);
end;
function TStBits.IterateFrom(Action : TBitIterateFunc;
UseSetBits, Up : Boolean;
OtherData : Pointer;
From : LongInt) : LongInt;
var
I, N, F : LongInt;
O : ShortInt;
B, TB : Byte;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if UseSetBits then
TB := 0
else
TB := $FF;
if Up then begin
{do the first possibly-partial byte}
N := MaxLong(From, 0);
F := MinLong(btBlockSize-1, N shr 3);
O := ShortInt(N) and 7;
B := btByte(F)^;
while (N <= FMax) and (O <= ShortInt(7)) do begin
if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
if not Action(Self, N, OtherData) then begin
Result := N;
Exit;
end;
inc(O);
inc(N);
end;
{do the rest of the bytes}
for I := F+1 to btBlockSize-1 do begin
B := btByte(I)^;
if B <> TB then begin
{byte has bits of interest}
O := 0;
while (N <= FMax) and (O < ShortInt(8)) do begin
if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
if not Action(Self, N, OtherData) then begin
Result := N;
Exit;
end;
inc(O);
inc(N);
end;
end else
inc(N, 8);
end;
end else begin
{do the last possibly-partial byte}
N := MinLong(From, FMax);
F := MaxLong(N, 0) shr 3;
O := ShortInt(N) and 7;
B := btByte(F)^;
while (N >= 0) and (O >= ShortInt(0)) do begin
if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
if not Action(Self, N, OtherData) then begin
Result := N;
Exit;
end;
dec(O);
dec(N);
end;
{do the rest of the bytes}
for I := F-1 downto 0 do begin
B := btByte(I)^;
if B <> TB then begin
{byte has bits of interest}
O := 7;
while (N >= 0) and (O >= ShortInt(0)) do begin
if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
if not Action(Self, N, OtherData) then begin
Result := N;
Exit;
end;
dec(O);
dec(N);
end;
end else
dec(N, 8);
end;
end;
{Iterated all bits}
Result := -1;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStBits.LastClear : LongInt;
begin
Result := IterateFrom(StopImmediately, False, False, nil, FMax);
end;
function TStBits.LastSet : LongInt;
begin
Result := IterateFrom(StopImmediately, True, False, nil, FMax);
end;
function TStBits.NextClear(N : LongInt) : LongInt;
begin
Result := IterateFrom(StopImmediately, False, True, nil, N+1);
end;
function TStBits.NextSet(N : LongInt) : LongInt;
begin
Result := IterateFrom(StopImmediately, True, True, nil, N+1);
end;
procedure TStBits.OrBits(B : TStBits);
var
I : LongInt;
P : PByte;
begin
{$IFDEF ThreadSafe}
EnterClassCS;
EnterCS;
B.EnterCS;
try
{$ENDIF}
if (not Assigned(B)) or (B.Max <> FMax) then
RaiseContainerError(stscBadType);
for I := 0 to btBlockSize-1 do begin
P := btByte(I);
P^ := P^ or B.btByte(I)^;
end;
btRecount;
{$IFDEF ThreadSafe}
finally
B.LeaveCS;
LeaveCS;
LeaveClassCS;
end;
{$ENDIF}
end;
function TStBits.PrevClear(N : LongInt) : LongInt;
begin
Result := IterateFrom(StopImmediately, False, False, nil, N-1);
end;
function TStBits.PrevSet(N : LongInt) : LongInt;
begin
Result := IterateFrom(StopImmediately, True, False, nil, N-1);
end;
procedure TStBits.SetBit(N : LongInt);
var
P : PByte;
M : Byte;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{$IFOPT R+}
if (N < 0) or (N > FMax) then
RaiseContainerError(stscBadIndex);
{$ENDIF}
P := btByte(N shr 3);
M := 1 shl (Byte(N) and 7);
if (P^ and M) = 0 then begin
P^ := P^ or M;
inc(FCount);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStBits.SetBits;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
HugeFillChar(btBits^, btBlockSize, $FF);
FCount := FMax+1;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStBits.SubBits(B : TStBits);
var
I : LongInt;
P : PByte;
begin
{$IFDEF ThreadSafe}
EnterClassCS;
EnterCS;
B.EnterCS;
try
{$ENDIF}
if (not Assigned(B)) or (B.Max <> FMax) then
RaiseContainerError(stscBadType);
for I := 0 to btBlockSize-1 do begin
P := btByte(I);
P^ := P^ and not B.btByte(I)^;
end;
btRecount;
{$IFDEF ThreadSafe}
finally
B.LeaveCS;
LeaveCS;
LeaveClassCS;
end;
{$ENDIF}
end;
procedure TStBits.ToggleBit(N : LongInt);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if BitIsSet(N) then
ClearBit(N)
else
SetBit(N);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStBits.LoadFromStream(S : TStream);
var
Reader : TReader;
StreamedClass : TPersistentClass;
StreamedClassName : String;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Clear;
Reader := TReader.Create(S, 1024);
try
with Reader do
begin
StreamedClassName := ReadString;
StreamedClass := GetClass(StreamedClassName);
if (StreamedClass = nil) then
RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
(not IsOrInheritsFrom(TStBits, StreamedClass)) then
RaiseContainerError(stscWrongClass);
Max := ReadInteger;
FCount := ReadInteger;
Read(btBits^, btBlockSize);
end;
finally
Reader.Free;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStBits.StoreToStream(S : TStream);
var
Writer : TWriter;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Writer := TWriter.Create(S, 1024);
try
with Writer do
begin
WriteString(Self.ClassName);
WriteInteger(Max);
WriteInteger(Count);
Write(btBits^, btBlockSize);
end;
finally
Writer.Free;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
{$IFDEF ThreadSafe}
initialization
Windows.InitializeCriticalSection(ClassCritSect);
finalization
Windows.DeleteCriticalSection(ClassCritSect);
{$ENDIF}
end.

1217
components/systools/source/run/stcoll.pas Normal file
View File

File diff suppressed because it is too large Load Diff

176
components/systools/source/run/stdque.pas Normal file
View File

@ -0,0 +1,176 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StDQue.pas 4.04 *}
{*********************************************************}
{* SysTools: DEQue class *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
{Notes:
This class is derived from TStList and allows all of
the inherited list methods to be used.
The "head" of the queue is element 0 in the list. The "tail" of the
queue is the last element in the list.
The dequeue can be used as a LIFO stack by calling PushTail and
PopTail, or as a FIFO queue by calling PushTail and PopHead.
}
unit StDQue;
interface
uses
Windows,
STConst, StBase, StList;
type
TStDQue = class(TStList)
public
procedure PushTail(Data : Pointer);
{-Add element at tail of queue}
procedure PopTail;
{-Delete element at tail of queue, destroys its data}
procedure PeekTail(var Data : Pointer);
{-Return data at tail of queue}
procedure PushHead(Data : Pointer);
{-Add element at head of queue}
procedure PopHead;
{-Delete element at head of queue, destroys its data}
procedure PeekHead(var Data : Pointer);
{-Return data at head of queue}
end;
{======================================================================}
implementation
procedure TStDQue.PeekHead(var Data : Pointer);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if Count = 0 then
Data := nil
else
Data := Head.Data;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDQue.PeekTail(var Data : Pointer);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if Count = 0 then
Data := nil
else
Data := Tail.Data;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDQue.PopHead;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if Count > 0 then
Delete(Head);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDQue.PopTail;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if Count > 0 then
Delete(Tail);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDQue.PushHead(Data : Pointer);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Insert(Data);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDQue.PushTail(Data : Pointer);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Append(Data);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
end.

155
components/systools/source/run/stnvbits.pas Normal file
View File

@ -0,0 +1,155 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StNVBits.pas 4.04 *}
{*********************************************************}
{* SysTools: non visual component for TStBits *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StNVBits;
interface
uses
{$IFNDEF FPC} Windows, {$ENDIF}
Classes,
StBase, StBits, StNVCont;
type
TStNVBits = class(TStNVContainerBase)
{.Z+}
protected {private}
{property variables}
FContainer : TStBits; {instance of the container}
FMaxBits : LongInt;
{property methods}
procedure SetMaxBits(Value : LongInt);
protected
{virtual property methods}
function GetOnLoadData : TStLoadDataEvent;
override;
function GetOnStoreData : TStStoreDataEvent;
override;
procedure SetOnLoadData(Value : TStLoadDataEvent);
override;
procedure SetOnStoreData(Value : TStStoreDataEvent);
override;
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
{.Z-}
property Container : TStBits
read FContainer;
published
property MaxBits : LongInt
read FMaxBits
write SetMaxBits default 100;
property OnLoadData;
property OnStoreData;
end;
implementation
{*** TStNVBits ***}
constructor TStNVBits.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{defaults}
FMaxBits := 100;
if Classes.GetClass(TStBits.ClassName) = nil then
RegisterClass(TStBits);
FContainer := TStBits.Create(FMaxBits-1);
end;
destructor TStNVBits.Destroy;
begin
FContainer.Free;
FContainer := nil;
inherited Destroy;
end;
function TStNVBits.GetOnLoadData : TStLoadDataEvent;
begin
Result := FContainer.OnLoadData;
end;
function TStNVBits.GetOnStoreData : TStStoreDataEvent;
begin
Result := FContainer.OnStoreData;
end;
procedure TStNVBits.SetMaxBits(Value : LongInt);
var
HoldOnLoadData : TStLoadDataEvent;
HoldOnStoreData : TStStoreDataEvent;
begin
{setting MaxBits will destroy exisiting data}
if Value < 0 then
Value := 0;
FMaxBits := Value;
HoldOnLoadData := FContainer.OnLoadData;
HoldOnStoreData := FContainer.OnStoreData;
FContainer.Free;
FContainer := TStBits.Create(FMaxBits-1);
FContainer.OnLoadData := HoldOnLoadData;
FContainer.OnStoreData := HoldOnStoreData;
end;
procedure TStNVBits.SetOnLoadData(Value : TStLoadDataEvent);
begin
FContainer.OnLoadData := Value;
end;
procedure TStNVBits.SetOnStoreData(Value : TStStoreDataEvent);
begin
FContainer.OnStoreData := Value;
end;
end.

196
components/systools/source/run/stnvcoll.pas Normal file
View File

@ -0,0 +1,196 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StNVColl.pas 4.04 *}
{*********************************************************}
{* SysTools: non visual component for TStCollection *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StNVColl;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
Classes,
StBase, StColl, StNVCont;
type
TStNVCollection = class(TStNVContainerBase)
{.Z+}
protected {private}
{property variables}
FContainer : TStCollection; {instance of the container}
FPageElements : Integer;
{property methods}
procedure SetPageElements(Value : Integer);
{internal methods}
procedure RecreateContainer;
protected
function GetOnCompare : TStCompareEvent;
override;
function GetOnDisposeData : TStDisposeDataEvent;
override;
function GetOnLoadData : TStLoadDataEvent;
override;
function GetOnStoreData : TStStoreDataEvent;
override;
procedure SetOnCompare(Value : TStCompareEvent);
override;
procedure SetOnDisposeData(Value : TStDisposeDataEvent);
override;
procedure SetOnLoadData(Value : TStLoadDataEvent);
override;
procedure SetOnStoreData(Value : TStStoreDataEvent);
override;
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
{.Z-}
property Container : TStCollection
read FContainer;
published
property PageElements : Integer
read FPageElements
write SetPageElements default 1000;
property OnCompare;
property OnDisposeData;
property OnLoadData;
property OnStoreData;
end;
implementation
{*** TStNVCollection ***}
constructor TStNVCollection.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{defaults}
FPageElements := 1000;
if Classes.GetClass(TStCollection.ClassName) = nil then
RegisterClass(TStCollection);
FContainer := TStCollection.Create(FPageElements);
end;
destructor TStNVCollection.Destroy;
begin
FContainer.Free;
FContainer := nil;
inherited Destroy;
end;
function TStNVCollection.GetOnCompare : TStCompareEvent;
begin
Result := FContainer.OnCompare;
end;
function TStNVCollection.GetOnDisposeData : TStDisposeDataEvent;
begin
Result := FContainer.OnDisposeData;
end;
function TStNVCollection.GetOnLoadData : TStLoadDataEvent;
begin
Result := FContainer.OnLoadData;
end;
function TStNVCollection.GetOnStoreData : TStStoreDataEvent;
begin
Result := FContainer.OnStoreData;
end;
procedure TStNVCollection.RecreateContainer;
var
HoldOnCompare : TStCompareEvent;
HoldOnDisposeData : TStDisposeDataEvent;
HoldOnLoadData : TStLoadDataEvent;
HoldOnStoreData : TStStoreDataEvent;
begin
HoldOnCompare := FContainer.OnCompare;
HoldOnDisposeData := FContainer.OnDisposeData;
HoldOnLoadData := FContainer.OnLoadData;
HoldOnStoreData := FContainer.OnStoreData;
FContainer.Free;
FContainer := TStCollection.Create(FPageElements);
FContainer.OnCompare := HoldOnCompare;
FContainer.OnDisposeData := HoldOnDisposeData;
FContainer.OnLoadData := HoldOnLoadData;
FContainer.OnStoreData := HoldOnStoreData;
end;
procedure TStNVCollection.SetOnCompare(Value : TStCompareEvent);
begin
FContainer.OnCompare := Value;
end;
procedure TStNVCollection.SetOnDisposeData(Value : TStDisposeDataEvent);
begin
FContainer.OnDisposeData := Value;
end;
procedure TStNVCollection.SetOnLoadData(Value : TStLoadDataEvent);
begin
FContainer.OnLoadData := Value;
end;
procedure TStNVCollection.SetOnStoreData(Value : TStStoreDataEvent);
begin
FContainer.OnStoreData := Value;
end;
procedure TStNVCollection.SetPageElements(Value : Integer);
begin
FPageElements := Value;
RecreateContainer;
end;
end.

139
components/systools/source/run/stnvcont.pas Normal file
View File

@ -0,0 +1,139 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StNVCont.pas 4.04 *}
{*********************************************************}
{* SysTools: non visual components for container classes *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StNVCont;
interface
uses
{$IFNDEF FPC} Windows, {$ENDIF}
Classes,
StBase, StBits;
type
TStContainerClass = class of TStContainer;
TStDisposeDataEvent = procedure(Sender : TObject; Data : Pointer)
of object;
TStLoadDataEvent = procedure(Sender : TObject; Reader : TReader; var Data : Pointer)
of object;
TStStoreDataEvent = procedure(Sender : TObject; Writer : TWriter; Data : Pointer)
of object;
{.Z+}
TStNVContainerBase = class(TStComponent)
protected
{virtual property methods}
function GetOnCompare : TStCompareEvent;
virtual;
function GetOnDisposeData : TStDisposeDataEvent;
virtual;
function GetOnLoadData : TStLoadDataEvent;
virtual;
function GetOnStoreData : TStStoreDataEvent;
virtual;
procedure SetOnCompare(Value : TStCompareEvent);
virtual;
procedure SetOnDisposeData(Value : TStDisposeDataEvent);
virtual;
procedure SetOnLoadData(Value : TStLoadDataEvent);
virtual;
procedure SetOnStoreData(Value : TStStoreDataEvent);
virtual;
{events}
property OnCompare : TStCompareEvent
read GetOnCompare
write SetOnCompare;
property OnDisposeData : TStDisposeDataEvent
read GetOnDisposeData
write SetOnDisposeData;
property OnLoadData : TStLoadDataEvent
read GetOnLoadData
write SetOnLoadData;
property OnStoreData : TStStoreDataEvent
read GetOnStoreData
write SetOnStoreData;
end;
{.Z-}
implementation
{*** TStNVContainerBase ***}
function TStNVContainerBase.GetOnCompare : TStCompareEvent;
begin
end;
function TStNVContainerBase.GetOnDisposeData : TStDisposeDataEvent;
begin
end;
function TStNVContainerBase.GetOnLoadData : TStLoadDataEvent;
begin
end;
function TStNVContainerBase.GetOnStoreData : TStStoreDataEvent;
begin
end;
procedure TStNVContainerBase.SetOnCompare(Value : TStCompareEvent);
begin
end;
procedure TStNVContainerBase.SetOnDisposeData(Value : TStDisposeDataEvent);
begin
end;
procedure TStNVContainerBase.SetOnLoadData(Value : TStLoadDataEvent);
begin
end;
procedure TStNVContainerBase.SetOnStoreData(Value : TStStoreDataEvent);
begin
end;
end.

183
components/systools/source/run/stnvdict.pas Normal file
View File

@ -0,0 +1,183 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StNVDict.pas 4.04 *}
{*********************************************************}
{* SysTools: non visual component for TStDictionary *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StNVDict;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
Classes,
StBase, StDict, StNVCont;
type
TStNVDictionary = class(TStNVContainerBase)
{.Z+}
protected {private}
{property variables}
FContainer : TStDictionary; {instance of the container}
FHashSize : Integer;
{property methods}
function GetHashSize : Integer;
function GetOnEqual : TStStringCompareEvent;
procedure SetHashSize(Value : Integer);
procedure SetOnEqual(Value : TStStringCompareEvent);
protected
function GetOnDisposeData : TStDisposeDataEvent;
override;
function GetOnLoadData : TStLoadDataEvent;
override;
function GetOnStoreData : TStStoreDataEvent;
override;
procedure SetOnDisposeData(Value : TStDisposeDataEvent);
override;
procedure SetOnLoadData(Value : TStLoadDataEvent);
override;
procedure SetOnStoreData(Value : TStStoreDataEvent);
override;
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
{.Z-}
property Container : TStDictionary
read FContainer;
published
property HashSize : Integer
read GetHashSize
write SetHashSize default 509;
property OnEqual : TStStringCompareEvent
read GetOnEqual
write SetOnEqual;
property OnDisposeData;
property OnLoadData;
property OnStoreData;
end;
implementation
{*** TStNVDictionary ***}
constructor TStNVDictionary.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{defaults}
FHashSize := 509;
if Classes.GetClass(TStDictionary.ClassName) = nil then
RegisterClass(TStDictionary);
if Classes.GetClass(TStDictNode.ClassName) = nil then
RegisterClass(TStDictNode);
FContainer := TStDictionary.Create(FHashSize);
end;
destructor TStNVDictionary.Destroy;
begin
FContainer.Free;
FContainer := nil;
inherited Destroy;
end;
function TStNVDictionary.GetHashSize : Integer;
begin
Result := FContainer.HashSize;
end;
function TStNVDictionary.GetOnDisposeData : TStDisposeDataEvent;
begin
Result := FContainer.OnDisposeData;
end;
function TStNVDictionary.GetOnEqual : TStStringCompareEvent;
begin
Result := FContainer.OnEqual;
end;
function TStNVDictionary.GetOnLoadData : TStLoadDataEvent;
begin
Result := FContainer.OnLoadData;
end;
function TStNVDictionary.GetOnStoreData : TStStoreDataEvent;
begin
Result := FContainer.OnStoreData;
end;
procedure TStNVDictionary.SetHashSize(Value : Integer);
begin
FContainer.HashSize := Value;
end;
procedure TStNVDictionary.SetOnDisposeData(Value : TStDisposeDataEvent);
begin
FContainer.OnDisposeData := Value;
end;
procedure TStNVDictionary.SetOnEqual(Value : TStStringCompareEvent);
begin
FContainer.OnEqual := Value;
end;
procedure TStNVDictionary.SetOnLoadData(Value : TStLoadDataEvent);
begin
FContainer.OnLoadData := Value;
end;
procedure TStNVDictionary.SetOnStoreData(Value : TStStoreDataEvent);
begin
FContainer.OnStoreData := Value;
end;
end.

161
components/systools/source/run/stnvdq.pas Normal file
View File

@ -0,0 +1,161 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StNVDQ.pas 4.04 *}
{*********************************************************}
{* SysTools: non visual component for TStDQue *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
// {$I StDefine.inc}
unit StNVDQ;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
Classes,
StBase, StList, StDQue, StNVCont;
type
TStNVDQue = class(TStNVContainerBase)
{.Z+}
protected {private}
{property variables}
FContainer : TStDQue; {instance of the container}
protected
function GetOnCompare : TStCompareEvent;
override;
function GetOnDisposeData : TStDisposeDataEvent;
override;
function GetOnLoadData : TStLoadDataEvent;
override;
function GetOnStoreData : TStStoreDataEvent;
override;
procedure SetOnCompare(Value : TStCompareEvent);
override;
procedure SetOnDisposeData(Value : TStDisposeDataEvent);
override;
procedure SetOnLoadData(Value : TStLoadDataEvent);
override;
procedure SetOnStoreData(Value : TStStoreDataEvent);
override;
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
{.Z-}
property Container : TStDQue
read FContainer;
published
property OnCompare;
property OnDisposeData;
property OnLoadData;
property OnStoreData;
end;
implementation
{*** TStNVDQue ***}
constructor TStNVDQue.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{defaults}
if Classes.GetClass(TStDQue.ClassName) = nil then
RegisterClass(TStDQue);
if Classes.GetClass(TStListNode.ClassName) = nil then
RegisterClass(TStListNode);
FContainer := TStDQue.Create(TStListNode);
end;
destructor TStNVDQue.Destroy;
begin
FContainer.Free;
FContainer := nil;
inherited Destroy;
end;
function TStNVDQue.GetOnCompare : TStCompareEvent;
begin
Result := FContainer.OnCompare;
end;
function TStNVDQue.GetOnDisposeData : TStDisposeDataEvent;
begin
Result := FContainer.OnDisposeData;
end;
function TStNVDQue.GetOnLoadData : TStLoadDataEvent;
begin
Result := FContainer.OnLoadData;
end;
function TStNVDQue.GetOnStoreData : TStStoreDataEvent;
begin
Result := FContainer.OnStoreData;
end;
procedure TStNVDQue.SetOnCompare(Value : TStCompareEvent);
begin
FContainer.OnCompare := Value;
end;
procedure TStNVDQue.SetOnDisposeData(Value : TStDisposeDataEvent);
begin
FContainer.OnDisposeData := Value;
end;
procedure TStNVDQue.SetOnLoadData(Value : TStLoadDataEvent);
begin
FContainer.OnLoadData := Value;
end;
procedure TStNVDQue.SetOnStoreData(Value : TStStoreDataEvent);
begin
FContainer.OnStoreData := Value;
end;
end.

225
components/systools/source/run/stnvlary.pas Normal file
View File

@ -0,0 +1,225 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StNVLAry.pas 4.04 *}
{*********************************************************}
{* SysTools: non visual component for TStLArray *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StNVLAry;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
Classes,
StBase, StLArr, StNVCont;
type
TStNVLArray = class(TStNVContainerBase)
{.Z+}
protected {private}
{property variables}
FContainer : TStLArray; {instance of the container}
FElementCount : LongInt;
FElementSize : Cardinal;
{property methods}
function GetStoreable : Boolean;
procedure SetElementCount(Value : LongInt);
procedure SetElementSize(Value : Cardinal);
procedure SetStoreable(Value : Boolean);
{internal methods}
procedure RecreateContainer;
protected
function GetOnCompare : TStCompareEvent;
override;
function GetOnDisposeData : TStDisposeDataEvent;
override;
function GetOnLoadData : TStLoadDataEvent;
override;
function GetOnStoreData : TStStoreDataEvent;
override;
procedure SetOnCompare(Value : TStCompareEvent);
override;
procedure SetOnDisposeData(Value : TStDisposeDataEvent);
override;
procedure SetOnLoadData(Value : TStLoadDataEvent);
override;
procedure SetOnStoreData(Value : TStStoreDataEvent);
override;
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
{.Z-}
property Container : TStLArray
read FContainer;
published
property ElementCount : LongInt
read FElementCount
write SetElementCount default 10;
property ElementSize : Cardinal
read FElementSize
write SetElementSize default SizeOf(LongInt);
property ElementsStorable : Boolean
read GetStoreable
write SetStoreable default False;
property OnCompare;
property OnDisposeData;
property OnLoadData;
property OnStoreData;
end;
implementation
{*** TStNVLArray ***}
constructor TStNVLArray.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{defaults}
FElementCount := 10;
FElementSize := SizeOf(LongInt);
if Classes.GetClass(TStLArray.ClassName) = nil then
RegisterClass(TStLArray);
FContainer := TStLArray.Create(FElementCount, FElementSize);
end;
destructor TStNVLArray.Destroy;
begin
FContainer.Free;
FContainer := nil;
inherited Destroy;
end;
function TStNVLArray.GetOnCompare : TStCompareEvent;
begin
Result := FContainer.OnCompare;
end;
function TStNVLArray.GetOnDisposeData : TStDisposeDataEvent;
begin
Result := FContainer.OnDisposeData;
end;
function TStNVLArray.GetOnLoadData : TStLoadDataEvent;
begin
Result := FContainer.OnLoadData;
end;
function TStNVLArray.GetOnStoreData : TStStoreDataEvent;
begin
Result := FContainer.OnStoreData;
end;
function TStNVLArray.GetStoreable : Boolean;
begin
Result := FContainer.ElementsStorable;
end;
procedure TStNVLArray.RecreateContainer;
var
HoldOnCompare : TStCompareEvent;
HoldOnDisposeData : TStDisposeDataEvent;
HoldOnLoadData : TStLoadDataEvent;
HoldOnStoreData : TStStoreDataEvent;
begin
HoldOnCompare := FContainer.OnCompare;
HoldOnDisposeData := FContainer.OnDisposeData;
HoldOnLoadData := FContainer.OnLoadData;
HoldOnStoreData := FContainer.OnStoreData;
FContainer.Free;
FContainer := TStLArray.Create(FElementCount, FElementSize);
FContainer.OnCompare := HoldOnCompare;
FContainer.OnDisposeData := HoldOnDisposeData;
FContainer.OnLoadData := HoldOnLoadData;
FContainer.OnStoreData := HoldOnStoreData;
end;
procedure TStNVLArray.SetElementCount(Value : LongInt);
begin
FElementCount := Value;
RecreateContainer;
end;
procedure TStNVLArray.SetElementSize(Value : Cardinal);
begin
FElementSize := Value;
RecreateContainer;
end;
procedure TStNVLArray.SetOnCompare(Value : TStCompareEvent);
begin
FContainer.OnCompare := Value;
end;
procedure TStNVLArray.SetOnDisposeData(Value : TStDisposeDataEvent);
begin
FContainer.OnDisposeData := Value;
end;
procedure TStNVLArray.SetOnLoadData(Value : TStLoadDataEvent);
begin
FContainer.OnLoadData := Value;
end;
procedure TStNVLArray.SetOnStoreData(Value : TStStoreDataEvent);
begin
FContainer.OnStoreData := Value;
end;
procedure TStNVLArray.SetStoreable(Value : Boolean);
begin
FContainer.ElementsStorable := Value;
end;
end.

163
components/systools/source/run/stnvlist.pas Normal file
View File

@ -0,0 +1,163 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StNVList.pas 4.04 *}
{*********************************************************}
{* SysTools: non visual component for TStList *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StNVList;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
Classes,
StBase, StList, StNVCont;
type
TStNVList = class(TStNVContainerBase)
{.Z+}
protected {private}
{property variables}
FContainer : TStList; {instance of the container}
protected
function GetOnCompare : TStCompareEvent;
override;
function GetOnDisposeData : TStDisposeDataEvent;
override;
function GetOnLoadData : TStLoadDataEvent;
override;
function GetOnStoreData : TStStoreDataEvent;
override;
procedure SetOnCompare(Value : TStCompareEvent);
override;
procedure SetOnDisposeData(Value : TStDisposeDataEvent);
override;
procedure SetOnLoadData(Value : TStLoadDataEvent);
override;
procedure SetOnStoreData(Value : TStStoreDataEvent);
override;
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
{.Z-}
property Container : TStList
read FContainer;
published
property OnCompare;
property OnDisposeData;
property OnLoadData;
property OnStoreData;
end;
implementation
{*** TStNVList ***}
constructor TStNVList.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{defaults}
if Classes.GetClass(TStList.ClassName) = nil then
RegisterClass(TStList);
if Classes.GetClass(TStListNode.ClassName) = nil then
RegisterClass(TStListNode);
FContainer := TStList.Create(TStListNode);
end;
destructor TStNVList.Destroy;
begin
FContainer.Free;
FContainer := nil;
inherited Destroy;
end;
function TStNVList.GetOnCompare : TStCompareEvent;
begin
Result := FContainer.OnCompare;
end;
function TStNVList.GetOnDisposeData : TStDisposeDataEvent;
begin
Result := FContainer.OnDisposeData;
end;
function TStNVList.GetOnLoadData : TStLoadDataEvent;
begin
Result := FContainer.OnLoadData;
end;
function TStNVList.GetOnStoreData : TStStoreDataEvent;
begin
Result := FContainer.OnStoreData;
end;
procedure TStNVList.SetOnCompare(Value : TStCompareEvent);
begin
FContainer.OnCompare := Value;
end;
procedure TStNVList.SetOnDisposeData(Value : TStDisposeDataEvent);
begin
FContainer.OnDisposeData := Value;
end;
procedure TStNVList.SetOnLoadData(Value : TStLoadDataEvent);
begin
FContainer.OnLoadData := Value;
end;
procedure TStNVList.SetOnStoreData(Value : TStStoreDataEvent);
begin
FContainer.OnStoreData := Value;
end;
end.

238
components/systools/source/run/stnvlmat.pas Normal file
View File

@ -0,0 +1,238 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StNVLMat.pas 4.04 *}
{*********************************************************}
{* SysTools:non visual component for TStLMatrix *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StNVLMat;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
Classes,
StBase, StLArr, StNVCont;
type
TStNVLMatrix = class(TStNVContainerBase)
{.Z+}
protected {private}
{property variables}
FContainer : TStLMatrix; {instance of the container}
FCols : Cardinal;
FRows : Cardinal;
FElementSize : Cardinal;
{property methods}
function GetStoreable : Boolean;
procedure SetCols(Value : Cardinal);
procedure SetRows(Value : Cardinal);
procedure SetElementSize(Value : Cardinal);
procedure SetStoreable(Value : Boolean);
{internal methods}
procedure RecreateContainer;
protected
function GetOnCompare : TStCompareEvent;
override;
function GetOnDisposeData : TStDisposeDataEvent;
override;
function GetOnLoadData : TStLoadDataEvent;
override;
function GetOnStoreData : TStStoreDataEvent;
override;
procedure SetOnCompare(Value : TStCompareEvent);
override;
procedure SetOnDisposeData(Value : TStDisposeDataEvent);
override;
procedure SetOnLoadData(Value : TStLoadDataEvent);
override;
procedure SetOnStoreData(Value : TStStoreDataEvent);
override;
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
{.Z-}
property Container : TStLMatrix
read FContainer;
published
property Cols : Cardinal
read FCols
write SetCols default 2;
property Rows : Cardinal
read FRows
write SetRows default 10;
property ElementSize : Cardinal
read FElementSize
write SetElementSize default SizeOf(LongInt);
property ElementsStorable : Boolean
read GetStoreable
write SetStoreable default False;
property OnCompare;
property OnDisposeData;
property OnLoadData;
property OnStoreData;
end;
implementation
{*** TStNVLMatrix ***}
constructor TStNVLMatrix.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{defaults}
FCols := 2;
FRows := 10;
FElementSize := SizeOf(LongInt);
if Classes.GetClass(TStLMatrix.ClassName) = nil then
RegisterClass(TStLMatrix);
FContainer := TStLMatrix.Create(FRows, FCols, FElementSize);
end;
destructor TStNVLMatrix.Destroy;
begin
FContainer.Free;
FContainer := nil;
inherited Destroy;
end;
function TStNVLMatrix.GetOnCompare : TStCompareEvent;
begin
Result := FContainer.OnCompare;
end;
function TStNVLMatrix.GetOnDisposeData : TStDisposeDataEvent;
begin
Result := FContainer.OnDisposeData;
end;
function TStNVLMatrix.GetOnLoadData : TStLoadDataEvent;
begin
Result := FContainer.OnLoadData;
end;
function TStNVLMatrix.GetOnStoreData : TStStoreDataEvent;
begin
Result := FContainer.OnStoreData;
end;
function TStNVLMatrix.GetStoreable : Boolean;
begin
Result := FContainer.ElementsStorable;
end;
procedure TStNVLMatrix.RecreateContainer;
var
HoldOnCompare : TStCompareEvent;
HoldOnDisposeData : TStDisposeDataEvent;
HoldOnLoadData : TStLoadDataEvent;
HoldOnStoreData : TStStoreDataEvent;
begin
HoldOnCompare := FContainer.OnCompare;
HoldOnDisposeData := FContainer.OnDisposeData;
HoldOnLoadData := FContainer.OnLoadData;
HoldOnStoreData := FContainer.OnStoreData;
FContainer.Free;
FContainer := TStLMatrix.Create(FRows, FCols, FElementSize);
FContainer.OnCompare := HoldOnCompare;
FContainer.OnDisposeData := HoldOnDisposeData;
FContainer.OnLoadData := HoldOnLoadData;
FContainer.OnStoreData := HoldOnStoreData;
end;
procedure TStNVLMatrix.SetCols(Value : Cardinal);
begin
FCols := Value;
RecreateContainer;
end;
procedure TStNVLMatrix.SetElementSize(Value : Cardinal);
begin
FElementSize := Value;
RecreateContainer;
end;
procedure TStNVLMatrix.SetOnCompare(Value : TStCompareEvent);
begin
FContainer.OnCompare := Value;
end;
procedure TStNVLMatrix.SetOnDisposeData(Value : TStDisposeDataEvent);
begin
FContainer.OnDisposeData := Value;
end;
procedure TStNVLMatrix.SetOnLoadData(Value : TStLoadDataEvent);
begin
FContainer.OnLoadData := Value;
end;
procedure TStNVLMatrix.SetOnStoreData(Value : TStStoreDataEvent);
begin
FContainer.OnStoreData := Value;
end;
procedure TStNVLMatrix.SetRows(Value : Cardinal);
begin
FRows := Value;
RecreateContainer;
end;
procedure TStNVLMatrix.SetStoreable(Value : Boolean);
begin
FContainer.ElementsStorable := Value;
end;
end.

210
components/systools/source/run/stnvscol.pas Normal file
View File

@ -0,0 +1,210 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StNVSCol.pas 4.04 *}
{*********************************************************}
{* SysTools: non visual component for TStSortedCollection*}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
{$I StDefine.inc}
unit StNVSCol;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
Classes,
StBase, StColl, StNVCont;
type
TStNVSortedCollection = class(TStNVContainerBase)
{.Z+}
protected {private}
{property variables}
FContainer : TStSortedCollection; {instance of the container}
FDuplicates : Boolean;
FPageElements : Integer;
{property methods}
procedure SetDuplicates(Value : Boolean);
procedure SetPageElements(Value : Integer);
{internal methods}
procedure RecreateContainer;
protected
function GetOnCompare : TStCompareEvent;
override;
function GetOnDisposeData : TStDisposeDataEvent;
override;
function GetOnLoadData : TStLoadDataEvent;
override;
function GetOnStoreData : TStStoreDataEvent;
override;
procedure SetOnCompare(Value : TStCompareEvent);
override;
procedure SetOnDisposeData(Value : TStDisposeDataEvent);
override;
procedure SetOnLoadData(Value : TStLoadDataEvent);
override;
procedure SetOnStoreData(Value : TStStoreDataEvent);
override;
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
{.Z-}
property Container : TStSortedCollection
read FContainer;
published
property Duplicates : Boolean
read FDuplicates
write SetDuplicates default False;
property PageElements : Integer
read FPageElements
write SetPageElements default 1000;
property OnCompare;
property OnDisposeData;
property OnLoadData;
property OnStoreData;
end;
implementation
{*** TStNVSortedCollection ***}
constructor TStNVSortedCollection.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{defaults}
FPageElements := 1000;
FDuplicates := False;
if Classes.GetClass(TStSortedCollection.ClassName) = nil then
RegisterClass(TStSortedCollection);
FContainer := TStSortedCollection.Create(FPageElements);
end;
destructor TStNVSortedCollection.Destroy;
begin
FContainer.Free;
FContainer := nil;
inherited Destroy;
end;
function TStNVSortedCollection.GetOnCompare : TStCompareEvent;
begin
Result := FContainer.OnCompare;
end;
function TStNVSortedCollection.GetOnDisposeData : TStDisposeDataEvent;
begin
Result := FContainer.OnDisposeData;
end;
function TStNVSortedCollection.GetOnLoadData : TStLoadDataEvent;
begin
Result := FContainer.OnLoadData;
end;
function TStNVSortedCollection.GetOnStoreData : TStStoreDataEvent;
begin
Result := FContainer.OnStoreData;
end;
procedure TStNVSortedCollection.RecreateContainer;
var
HoldOnCompare : TStCompareEvent;
HoldOnDisposeData : TStDisposeDataEvent;
HoldOnLoadData : TStLoadDataEvent;
HoldOnStoreData : TStStoreDataEvent;
begin
HoldOnCompare := FContainer.OnCompare;
HoldOnDisposeData := FContainer.OnDisposeData;
HoldOnLoadData := FContainer.OnLoadData;
HoldOnStoreData := FContainer.OnStoreData;
FContainer.Free;
FContainer := TStSortedCollection.Create(FPageElements);
FContainer.OnCompare := HoldOnCompare;
FContainer.OnDisposeData := HoldOnDisposeData;
FContainer.OnLoadData := HoldOnLoadData;
FContainer.OnStoreData := HoldOnStoreData;
end;
procedure TStNVSortedCollection.SetOnCompare(Value : TStCompareEvent);
begin
FContainer.OnCompare := Value;
end;
procedure TStNVSortedCollection.SetOnDisposeData(Value : TStDisposeDataEvent);
begin
FContainer.OnDisposeData := Value;
end;
procedure TStNVSortedCollection.SetOnLoadData(Value : TStLoadDataEvent);
begin
FContainer.OnLoadData := Value;
end;
procedure TStNVSortedCollection.SetOnStoreData(Value : TStStoreDataEvent);
begin
FContainer.OnStoreData := Value;
end;
procedure TStNVSortedCollection.SetDuplicates(Value : Boolean);
begin
FDuplicates := Value;
FContainer.Duplicates := FDuplicates;
end;
procedure TStNVSortedCollection.SetPageElements(Value : Integer);
begin
FPageElements := Value;
RecreateContainer;
FContainer.Duplicates := FDuplicates;
end;
end.

160
components/systools/source/run/stnvtree.pas Normal file
View File

@ -0,0 +1,160 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StNVTree.pas 4.04 *}
{*********************************************************}
{* SysTools: non visual component for TStTree *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StNVTree;
interface
uses
{$IFNDEF FPC}Windows,{$ENDIF}
Classes,
StBase, StTree, StNVCont;
type
TStNVTree = class(TStNVContainerBase)
{.Z+}
protected {private}
{property variables}
FContainer : TStTree; {instance of the container}
protected
function GetOnCompare : TStCompareEvent;
override;
function GetOnDisposeData : TStDisposeDataEvent;
override;
function GetOnLoadData : TStLoadDataEvent;
override;
function GetOnStoreData : TStStoreDataEvent;
override;
procedure SetOnCompare(Value : TStCompareEvent);
override;
procedure SetOnDisposeData(Value : TStDisposeDataEvent);
override;
procedure SetOnLoadData(Value : TStLoadDataEvent);
override;
procedure SetOnStoreData(Value : TStStoreDataEvent);
override;
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
{.Z-}
property Container : TStTree
read FContainer;
published
property OnCompare;
property OnDisposeData;
property OnLoadData;
property OnStoreData;
end;
implementation
{*** TStNVTree ***}
constructor TStNVTree.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{defaults}
if Classes.GetClass(TStTree.ClassName) = nil then
RegisterClass(TStTree);
if Classes.GetClass(TStTreeNode.ClassName) = nil then
RegisterClass(TStTreeNode);
FContainer := TStTree.Create(TStTreeNode);
end;
destructor TStNVTree.Destroy;
begin
FContainer.Free;
FContainer := nil;
inherited Destroy;
end;
function TStNVTree.GetOnCompare : TStCompareEvent;
begin
Result := FContainer.OnCompare;
end;
function TStNVTree.GetOnDisposeData : TStDisposeDataEvent;
begin
Result := FContainer.OnDisposeData;
end;
function TStNVTree.GetOnLoadData : TStLoadDataEvent;
begin
Result := FContainer.OnLoadData;
end;
function TStNVTree.GetOnStoreData : TStStoreDataEvent;
begin
Result := FContainer.OnStoreData;
end;
procedure TStNVTree.SetOnCompare(Value : TStCompareEvent);
begin
FContainer.OnCompare := Value;
end;
procedure TStNVTree.SetOnDisposeData(Value : TStDisposeDataEvent);
begin
FContainer.OnDisposeData := Value;
end;
procedure TStNVTree.SetOnLoadData(Value : TStLoadDataEvent);
begin
FContainer.OnLoadData := Value;
end;
procedure TStNVTree.SetOnStoreData(Value : TStStoreDataEvent);
begin
FContainer.OnStoreData := Value;
end;
end.

742
components/systools/source/run/stpqueue.pas Normal file
View File

@ -0,0 +1,742 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StPQueue.pas 4.04 *}
{*********************************************************}
{* SysTools: Priority Queue Classes *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
{Notes:
Based on the double-ended heap (deap) described in Horowitz and Sahni,
Data Structures and Algorithms in C.
The deap was first reported in:
Svante Carlsson, "The Deap - a double-ended heap to implement double-
ended priority queues", Information Processing Letters, 26,
pp. 33-36, 1987.
A deap is a complete binary tree. The root node holds no data. Its
left subtree is a min heap. Its right subtree is a max heap. If the right
subtree is not empty, let i be any node in the left subtree. Let j be
the node at the corresponding position in the right subtree. If such a
j does not exist, let j be the node in the right subtree at the position
corresponding to i's parent. The deap has the property that the data in
node i is less than or equal to the data in node j.
Insertion is an O(log2(n)) operation. Deletion of the min or max node
is also an O(log2(n)) operation.
Data elements in the deap are pointers, which can point to any record
structure or class, or can contain any data type of 4 bytes or less.
The deap needs an ordering relationship, so it is essential to assign
to the Compare property inherited from the TStContainer class.
STPQUEUE uses the DisposeData procedure of TStContainer to determine
how to free elements in the collection. By default, it does nothing.
In 16-bit programs the deap is limited to 16380 elements. In 32-bit
programs the limit is set by memory usage or performance.
}
unit StPQueue;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
SysUtils, Classes,
StConst, StBase;
type
{first actual element is at index 2}
{.Z+}
TStPQData = array[2..(StMaxBlockSize div SizeOf(Pointer))+1] of Pointer;
PStPQData = ^TStPQData;
{.Z-}
TStPQueue = class(TStContainer)
{.Z+}
protected {private}
pqData : PStPQData; {data - the complete binary tree}
pqCapacity : Integer; {max elements currently possible}
pqDelta : Integer; {delta elements to grow when needed}
procedure ForEachPointer(Action : TIteratePointerFunc; OtherData : Pointer);
override;
function StoresPointers : Boolean;
override;
procedure Expand(Need : Integer);
procedure InsertMin(I : Integer; Data : Pointer);
procedure InsertMax(I : Integer; Data : Pointer);
procedure ModifiedInsert(I : Integer; Data : Pointer);
{.Z-}
public
constructor Create(InitCapacity, Delta : Integer);
virtual;
{-Initialize an empty PQueue of given capacity. If it overflows
grow the PQueue by Delta elements}
destructor Destroy;
override;
{-Free a PQueue}
procedure LoadFromStream(S : TStream);
override;
{-Create a PQueue and its data from a stream}
procedure StoreToStream(S : TStream);
override;
{-Write a PQueue and its data to a stream}
procedure Clear;
override;
{-Remove all data from container but leave it instantiated and
with its current capacity}
procedure Insert(Data : Pointer);
{-Add a new node}
function DeleteMin : Pointer;
{-Remove the minimum node and return its Pointer}
function DeleteMax : Pointer;
{-Remove the maximum node and return its Pointer}
procedure Assign(Source : TPersistent);
override;
{-Assign another container's contents to this one. Only SysTools
containers that store pointers are allowed.}
procedure Join(Q : TStPQueue);
{-Add PQueue Q into this one and dispose Q}
function Iterate(Action : TIteratePointerFunc;
OtherData : Pointer) : Pointer;
{-Call Action for all the nodes or until Action returns false. Note
that the nodes are visited in no particular order.}
function Test : Boolean;
{-Determine whether deap properties are currently valid (for debugging)}
end;
{.Z+}
TStPQueueClass = class of TStPQueue;
{.Z-}
implementation
{$IFDEF ThreadSafe}
var
ClassCritSect : TRTLCriticalSection;
{$ENDIF}
type
TStoreInfo = record
Wtr : TWriter;
SDP : TStoreDataProc;
end;
function AssignData(Container : TStContainer;
Data, OtherData : Pointer) : Boolean; far;
begin
TStPQueue(OtherData).Insert(Data);
AssignData := True;
end;
function DestroyNode(Container : TStContainer;
Data, OtherData : Pointer) : Boolean; far;
begin
if Assigned(Data) then
Container.DoDisposeData(Data);
DestroyNode := True;
end;
procedure EnterClassCS;
begin
{$IFDEF ThreadSafe}
EnterCriticalSection(ClassCritSect);
{$ENDIF}
end;
function JoinData(Container : TStContainer;
Data, OtherData : Pointer) : Boolean; far;
begin
TStPQueue(OtherData).Insert(Data);
JoinData := True;
end;
procedure LeaveClassCS;
begin
{$IFDEF ThreadSafe}
LeaveCriticalSection(ClassCritSect);
{$ENDIF}
end;
function log2(I : Integer) : Integer;
{-Return the Integer below log2(I)}
begin
Result := 0;
while (I > 1) do begin
Inc(Result);
I := I shr 1;
end;
end;
function StoreNode(Container : TStContainer;
Data, OtherData : Pointer) : Boolean; far;
begin
StoreNode := True;
with TStoreInfo(OtherData^) do
SDP(Wtr, Data);
end;
procedure TStPQueue.Assign(Source : TPersistent);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if not AssignPointers(Source, AssignData) then
inherited Assign(Source);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStPQueue.Clear;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if conNodeProt = 0 then
ForEachPointer(StPQueue.DestroyNode, nil);
FCount := 0;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
constructor TStPQueue.Create(InitCapacity, Delta : Integer);
begin
if (InitCapacity < 2) or (Delta < 1) then
RaiseContainerError(stscBadSize);
FCount := 0;
{ensure that Expand creates initial capacity InitCapacity}
pqCapacity := -Delta;
pqDelta := Delta;
pqData := nil;
CreateContainer(TStNode, 0);
Expand(InitCapacity);
end;
function TStPQueue.DeleteMin : Pointer;
var
I, j, n : Integer;
Temp : Pointer;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if (FCount < 1) then begin
{deap is empty}
DeleteMin := nil;
exit;
end;
{return min element}
DeleteMin := pqData^[2];
{save last element and reset (helps debugging)}
Temp := pqData^[FCount+1];
pqData^[FCount+1] := nil;
{decrement count, n is index of new last element}
n := FCount;
dec(FCount);
if (FCount > 0) then begin
{move empty min-root down to an appropriate leaf}
I := 2;
while (I shl 1 <= n) do begin
{find child with smaller key}
j := I shl 1;
if (j+1 <= n) then
if (DoCompare(pqData^[j], pqData^[j+1]) > 0) then
Inc(j);
pqData^[I] := pqData^[j];
I := j;
end;
{insert the old last element at the given leaf position}
ModifiedInsert(I, Temp);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStPQueue.DeleteMax : Pointer;
var
I, j, n : Integer;
Temp : Pointer;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if (FCount < 1) then begin
{deap is empty}
DeleteMax := nil;
exit;
end;
{return max element}
if (FCount = 1) then
DeleteMax := pqData^[2]
else
DeleteMax := pqData^[3];
{save last element and reset (helps debugging)}
Temp := pqData^[FCount+1];
pqData^[FCount+1] := nil;
{decrement count, n is index of new last element}
n := FCount;
dec(FCount);
if (FCount > 0) then begin
{move empty max-root down to an appropriate leaf}
I := 3;
while (I shl 1 <= n) do begin
{find child with larger key}
j := I shl 1;
if (j+1 <= n) then
if (DoCompare(pqData^[j], pqData^[j+1]) < 0) then
Inc(j);
pqData^[I] := pqData^[j];
I := j;
end;
{insert the old last element at the given leaf position}
ModifiedInsert(I, Temp);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
destructor TStPQueue.Destroy;
begin
if (pqData <> nil) then begin
Clear;
FreeMem(pqData, pqCapacity*SizeOf(Pointer));
end;
IncNodeProtection;
inherited Destroy;
end;
procedure TStPQueue.Expand(Need : Integer);
var
NewCapacity : Integer;
Size : LongInt;
NewData : PStPQData;
begin
if Need > pqCapacity then begin
{determine new capacity}
NewCapacity := pqCapacity+pqDelta;
if (NewCapacity < Need) then
NewCapacity := Need;
{make sure it's feasible to allocate it}
Size := LongInt(NewCapacity)*SizeOf(Pointer);
{if Size > MaxBlockSize then}
{RaiseContainerError(stscBadSize);}
{allocate new data}
GetMem(NewData, Size);
{copy old data to it and free old data}
if (pqData <> nil) then begin
move(pqData^, NewData^, pqCapacity*SizeOf(Pointer));
FreeMem(pqData, pqCapacity*SizeOf(Pointer));
end;
{update instance variables}
pqData := NewData;
pqCapacity := NewCapacity;
end;
end;
procedure TStPQueue.ForEachPointer(Action : TIteratePointerFunc; OtherData : Pointer);
var
I : Integer;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{first element is 2, last is FCount+1}
for I := 2 to FCount+1 do
if not Action(Self, pqData^[I], OtherData) then
Exit;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStPQueue.Insert(Data : Pointer);
var
I, n, p : Integer;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{adding an element, make sure there's space}
Inc(FCount);
Expand(FCount);
if (FCount = 1) then
{insert into empty deap}
pqData^[2] := Data
else begin
{n is the actual array index}
n := FCount+1;
{determine whether n is in the min or max subtree}
p := n;
while (p > 3) do
p := p shr 1;
if (p = 2) then begin
{n is a position on the min side}
{I is its partner on the max side}
I := (n+(1 shl (log2(n)-1))) shr 1;
if (DoCompare(Data, pqData^[I]) > 0) then begin
pqData^[n] := pqData^[I];
InsertMax(I, Data);
end else
InsertMin(n, Data);
end else begin
{n is a position on the max side}
{I is its partner on the min side}
I := n-(1 shl (log2(n)-1));
if (DoCompare(Data, pqData^[I]) < 0) then begin
pqData^[n] := pqData^[I];
InsertMin(I, Data);
end else
InsertMax(n, Data);
end;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStPQueue.InsertMin(I : Integer; Data : Pointer);
{-Insert into min-heap rooted at node 2}
var
j : Integer;
begin
while (I > 2) and (DoCompare(Data, pqData^[I shr 1]) < 0) do begin
j := I shr 1;
pqData^[I] := pqData^[j];
I := j;
end;
pqData^[I] := Data;
end;
procedure TStPQueue.InsertMax(I : Integer; Data : Pointer);
{-Insert into max-heap rooted at node 3}
var
j : Integer;
begin
while (I > 3) and (DoCompare(Data, pqData^[I shr 1]) > 0) do begin
j := I shr 1;
pqData^[I] := pqData^[j];
I := j;
end;
pqData^[I] := Data;
end;
function TStPQueue.Iterate(Action : TIteratePointerFunc;
OtherData : Pointer) : Pointer;
var
I : Integer;
begin
Iterate := nil;
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{first element is 2, last is FCount+1}
for I := 2 to FCount+1 do
if not Action(Self, pqData^[I], OtherData) then begin
Iterate := pqData^[I];
Exit;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStPQueue.Join(Q : TStPQueue);
begin
{$IFDEF ThreadSafe}
EnterClassCS;
EnterCS;
Q.EnterCS;
try
{$ENDIF}
if (not Assigned(Q)) then
RaiseContainerError(stscBadType);
Q.ForEachPointer(JoinData, Self);
Q.IncNodeProtection;
Q.Free;
{$IFDEF ThreadSafe}
finally
Q.LeaveCS;
LeaveCS;
LeaveClassCS;
end;
{$ENDIF}
end;
procedure TStPQueue.LoadFromStream(S : TStream);
var
Data : Pointer;
Reader : TReader;
StreamedClass : TPersistentClass;
StreamedClassName : string;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Clear;
Reader := TReader.Create(S, 1024);
try
with Reader do begin
StreamedClassName := ReadString;
StreamedClass := GetClass(StreamedClassName);
if (StreamedClass = nil) then
RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
(not IsOrInheritsFrom(TStPQueue, StreamedClass)) then
RaiseContainerError(stscWrongClass);
ReadListBegin;
while not EndOfList do begin
Data := DoLoadData(Reader);
Insert(Data);
end;
ReadListEnd;
end;
finally
Reader.Free;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStPQueue.ModifiedInsert(I : Integer; Data : Pointer);
{-Special insert after a delete. I is the actual array index where
insertion of Data occurs. Tree does not grow.}
var
p, j : Integer;
begin
if (I > 1) then begin
{determine whether I is in the min or max subtree}
p := I;
while (p > 3) do
p := p shr 1;
if (p = 2) then begin
{I is a position on the min side}
{j is its partner on the max side}
j := I+(1 shl (log2(I)-1));
if (j > FCount+1) then
j := j shr 1;
if (j < 3) then
{empty max heap}
pqData^[I] := Data
else if (DoCompare(Data, pqData^[j]) > 0) then begin
pqData^[I] := pqData^[j];
InsertMax(j, Data);
end else
InsertMin(I, Data);
end else begin
{I is a position on the max side}
{j is its partner on the min side}
j := I-(1 shl (log2(I)-1));
{check its children too to preserve deap property}
if (j shl 1 <= FCount+1) then begin
j := j shl 1;
if (j+1 <= FCount+1) then
if (DoCompare(pqData^[j], pqData^[j+1]) < 0) then
Inc(j);
end;
if (DoCompare(Data, pqData^[j]) < 0) then begin
pqData^[I] := pqData^[j];
InsertMin(j, Data);
end else
InsertMax(I, Data);
end;
end;
end;
function TStPQueue.StoresPointers : Boolean;
begin
StoresPointers := True;
end;
procedure TStPQueue.StoreToStream(S : TStream);
var
Writer : TWriter;
StoreInfo : TStoreInfo;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Writer := TWriter.Create(S, 1024);
try
with Writer do begin
WriteString(Self.ClassName);
WriteListBegin;
StoreInfo.Wtr := Writer;
StoreInfo.SDP := StoreData;
Iterate(StoreNode, @StoreInfo);
WriteListEnd;
end;
finally
Writer.Free;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStPQueue.Test : Boolean;
var
I, i2, j, n, p : Integer;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Test := True;
if (FCount = 0) then
exit;
n := FCount+1;
{start with each leaf node}
for I := (1 shl log2(n)) to n do begin
p := I;
while (p > 3) do
p := p shr 1;
if (p = 2) then begin
{I is a position on the min side}
{test min-heap condition}
i2 := I;
while (i2 shr 1 >= 2) do begin
j := i2 shr 1;
if (DoCompare(pqData^[j], pqData^[i2]) > 0) then begin
Test := false;
{writeln('min: j=', j, ' i2=', i2,
' d[j]=', Integer(pqData^[j]), ' d[i2]=', Integer(pqData^[i2]));}
exit;
end;
i2 := j;
end;
{test deap condition}
if n >= 3 then begin
j := I+(1 shl (log2(I)-1));
if (j > n) then
j := j shr 1;
if (DoCompare(pqData^[I], pqData^[j]) > 0) then begin
Test := false;
{writeln('deap: j=', j, ' I=', I,
' d[j]=', Integer(pqData^[j]), ' d[I]=', Integer(pqData^[I]));}
exit;
end;
end;
end else begin
{I is a position on the max side}
{test max-heap condition}
i2 := I;
while (i2 shr 1 >= 3) do begin
j := i2 shr 1;
if (DoCompare(pqData^[j], pqData^[i2]) < 0) then begin
Test := false;
{writeln('max: j=', j, ' i2=', i2,
' d[j]=', Integer(pqData^[j]), ' d[i2]=', Integer(pqData^[i2]));}
exit;
end;
i2 := j;
end;
end;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
{$IFDEF ThreadSafe}
initialization
Windows.InitializeCriticalSection(ClassCritSect);
finalization
Windows.DeleteCriticalSection(ClassCritSect);
{$ENDIF}
end.

935
components/systools/source/run/sttree.pas Normal file
View File

@ -0,0 +1,935 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StTree.pas 4.04 *}
{*********************************************************}
{* SysTools: AVL Tree class *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
{Notes:
- These binary trees are self-balancing in the AVL sense (the depth
of any left branch differs by no more than one from the depth of the
right branch).
- Duplicate data is not allowed in a tree.
- Nodes can be of type TStTreeNode or any descendant.
- The Compare property of the TStContainer ancestor must be set to
specify the sort order of the tree. The Compare function operates
on Data pointers. The Data pointer could be typecast to a number
(any integer type), to a string pointer, to a record pointer, or to
an instance of a class.
- Next and Prev should not be used to iterate through an entire tree.
This is much slower than calling the Iterate method.
}
unit StTree;
interface
uses
{$IFNDEF FPC}Windows,{$ENDIF}
SysUtils, Classes, StConst, StBase;
type
TStTreeNode = class(TStNode)
{.Z+}
protected
tnPos : array[Boolean] of TStTreeNode; {Child nodes}
tnBal : Integer; {Used during balancing}
{.Z-}
public
constructor Create(AData : Pointer); override;
{-Initialize node}
end;
TStTree = class(TStContainer)
{.Z+}
protected
trRoot : TStTreeNode; {Root of tree}
trIgnoreDups : Boolean; {Ignore duplicates during Join?}
procedure ForEachPointer(Action : TIteratePointerFunc; OtherData : pointer);
override;
function StoresPointers : boolean;
override;
procedure trInsertNode(N : TStTreeNode);
{.Z-}
public
constructor Create(NodeClass : TStNodeClass); virtual;
{-Initialize an empty tree}
procedure LoadFromStream(S : TStream); override;
{-Create a list and its data from a stream}
procedure StoreToStream(S : TStream); override;
{-Write a list and its data to a stream}
procedure Clear; override;
{-Remove all nodes from container but leave it instantiated}
function Insert(Data : Pointer) : TStTreeNode;
{-Add a new node}
procedure Delete(Data : Pointer);
{-Delete a node}
function Find(Data : Pointer) : TStTreeNode;
{-Return node that matches Data}
procedure Assign(Source: TPersistent); override;
{-Assign another container's contents to this one}
procedure Join(T: TStTree; IgnoreDups : Boolean);
{-Add tree T into this one and dispose T}
function Split(Data : Pointer) : TStTree;
{-Split tree, putting all nodes above and including Data into new tree}
function Iterate(Action : TIterateFunc; Up : Boolean;
OtherData : Pointer) : TStTreeNode;
{-Call Action for all the nodes, returning the last node visited}
function First : TStTreeNode;
{-Return the smallest-value node in the tree}
function Last : TStTreeNode;
{-Return the largest-value node in the tree}
function Next(N : TStTreeNode) : TStTreeNode;
{-Return the next node whose value is larger than N's}
function Prev(N : TStTreeNode) : TStTreeNode;
{-Return the largest node whose value is smaller than N's}
end;
{.Z+}
TStTreeClass = class of TStTree;
{.Z-}
{======================================================================}
implementation
{$IFDEF ThreadSafe}
var
ClassCritSect : TRTLCriticalSection;
{$ENDIF}
procedure EnterClassCS;
begin
{$IFDEF ThreadSafe}
EnterCriticalSection(ClassCritSect);
{$ENDIF}
end;
procedure LeaveClassCS;
begin
{$IFDEF ThreadSafe}
LeaveCriticalSection(ClassCritSect);
{$ENDIF}
end;
const
Left = False;
Right = True;
{Following stack declarations are used to avoid recursion in all tree
routines. Because the tree is AVL-balanced, a stack size of 40
allows at least 2**32 elements in the tree without overflowing the
stack.}
const
StackSize = 40;
type
StackNode =
record
Node : TStTreeNode;
Comparison : Integer;
end;
StackArray = array[1..StackSize] of StackNode;
constructor TStTreeNode.Create(AData : Pointer);
begin
inherited Create(AData);
end;
{----------------------------------------------------------------------}
function Sign(I : Integer) : Integer;
begin
if I < 0 then
Sign := -1
else if I > 0 then
Sign := +1
else
Sign := 0;
end;
procedure DelBalance(var P : TStTreeNode; var SubTreeDec : Boolean; CmpRes : Integer);
var
P1, P2 : TStTreeNode;
B1, B2 : Integer;
LR : Boolean;
begin
CmpRes := Sign(CmpRes);
if P.tnBal = CmpRes then
P.tnBal := 0
else if P.tnBal = 0 then begin
P.tnBal := -CmpRes;
SubTreeDec := False;
end else begin
LR := (CmpRes < 0);
P1 := P.tnPos[LR];
B1 := P1.tnBal;
if (B1 = 0) or (B1 = -CmpRes) then begin
{Single RR or LL rotation}
P.tnPos[LR] := P1.tnPos[not LR];
P1.tnPos[not LR] := P;
if B1 = 0 then begin
P.tnBal := -CmpRes;
P1.tnBal := CmpRes;
SubTreeDec := False;
end else begin
P.tnBal := 0;
P1.tnBal := 0;
end;
P := P1;
end else begin
{Double RL or LR rotation}
P2 := P1.tnPos[not LR];
B2 := P2.tnBal;
P1.tnPos[not LR] := P2.tnPos[LR];
P2.tnPos[LR] := P1;
P.tnPos[LR] := P2.tnPos[not LR];
P2.tnPos[not LR] := P;
if B2 = -CmpRes then
P.tnBal := CmpRes
else
P.tnBal := 0;
if B2 = CmpRes then
P1.tnBal := -CmpRes
else
P1.tnBal := 0;
P := P2;
P2.tnBal := 0;
end;
end;
end;
procedure InsBalance(var P : TStTreeNode; var SubTreeInc : Boolean;
CmpRes : Integer);
var
P1 : TStTreeNode;
P2 : TStTreeNode;
LR : Boolean;
begin
CmpRes := Sign(CmpRes);
if P.tnBal = -CmpRes then begin
P.tnBal := 0;
SubTreeInc := False;
end else if P.tnBal = 0 then
P.tnBal := CmpRes
else begin
LR := (CmpRes > 0);
P1 := P.tnPos[LR];
if P1.tnBal = CmpRes then begin
P.tnPos[LR] := P1.tnPos[not LR];
P1.tnPos[not LR] := P;
P.tnBal := 0;
P := P1;
end else begin
P2 := P1.tnPos[not LR];
P1.tnPos[not LR] := P2.tnPos[LR];
P2.tnPos[LR] := P1;
P.tnPos[LR] := P2.tnPos[not LR];
P2.tnPos[not LR] := P;
if P2.tnBal = CmpRes then
P.tnBal := -CmpRes
else
P.tnBal := 0;
if P2.tnBal = -CmpRes then
P1.tnBal := CmpRes
else
P1.tnBal := 0;
P := P2;
end;
P.tnBal := 0;
SubTreeInc := False;
end;
end;
function JoinNode(Container : TStContainer; Node : TStNode;
OtherData : Pointer) : Boolean; far;
var
N : TStTreeNode;
begin
Result := True;
N := TStTree(OtherData).Find(Node.Data);
if Assigned(N) then
if TStTree(OtherData).trIgnoreDups then begin
Node.Free;
Exit;
end else
RaiseContainerError(stscDupNode);
with TStTreeNode(Node) do begin
tnPos[Left] := nil;
tnPos[Right] := nil;
tnBal := 0;
end;
TStTree(OtherData).trInsertNode(TStTreeNode(Node));
end;
type
SplitRec =
record
SData : Pointer;
STree : TStTree;
end;
function SplitTree(Container : TStContainer; Node : TStNode;
OtherData : Pointer) : Boolean; far;
var
D : Pointer;
begin
Result := True;
if Container.DoCompare(Node.Data, SplitRec(OtherData^).SData) >= 0 then begin
D := Node.Data;
TStTree(Container).Delete(D);
SplitRec(OtherData^).STree.Insert(D);
end;
end;
type
TStoreInfo = record
Wtr : TWriter;
SDP : TStoreDataProc;
end;
function StoreNode(Container : TStContainer; Node : TStNode;
OtherData : Pointer) : Boolean; far;
begin
Result := True;
with TStoreInfo(OtherData^) do
SDP(Wtr, Node.Data);
end;
function AssignData(Container : TStContainer;
Data, OtherData : Pointer) : Boolean; far;
var
OurTree : TStTree absolute OtherData;
begin
OurTree.Insert(Data);
Result := true;
end;
{----------------------------------------------------------------------}
procedure TStTree.Assign(Source: TPersistent);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{The only containers that we allow to be assigned to a tree are
- a SysTools linked list (TStList)
- another SysTools binary search tree (TStTree)
- a SysTools collection (TStCollection, TStSortedCollection)}
if not AssignPointers(Source, AssignData) then
inherited Assign(Source);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;{try..finally}
{$ENDIF}
end;
procedure TStTree.Clear;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if conNodeProt = 0 then
Iterate(DestroyNode, True, nil);
trRoot := nil;
FCount := 0;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStTree.ForEachPointer(Action : TIteratePointerFunc;
OtherData : pointer);
var
P : TStTreeNode;
Q : TStTreeNode;
StackP : Integer;
Stack : StackArray;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
StackP := 0;
P := trRoot;
repeat
while Assigned(P) do begin
Inc(StackP);
Stack[StackP].Node := P;
P := P.tnPos[false];
end;
if StackP = 0 then begin
Exit;
end;
P := Stack[StackP].Node;
Dec(StackP);
Q := P;
P := P.tnPos[true];
if not Action(Self, Q.Data, OtherData) then begin
Exit;
end;
until False;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStTree.StoresPointers : boolean;
begin
Result := true;
end;
constructor TStTree.Create(NodeClass : TStNodeClass);
begin
CreateContainer(NodeClass, 0);
end;
procedure TStTree.Delete(Data : Pointer);
var
P : TStTreeNode;
Q : TStTreeNode;
TmpData : Pointer;
CmpRes : Integer;
Found : Boolean;
SubTreeDec : Boolean;
StackP : Integer;
Stack : StackArray;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
P := trRoot;
if not Assigned(P) then
Exit;
{Find node to delete and stack the nodes to reach it}
Found := False;
StackP := 0;
while not Found do begin
CmpRes := DoCompare(Data, P.Data);
Inc(StackP);
if CmpRes = 0 then begin
{Found node to delete}
with Stack[StackP] do begin
Node := P;
Comparison := -1;
end;
Found := True;
end else begin
with Stack[StackP] do begin
Node := P;
Comparison := CmpRes;
end;
P := P.tnPos[CmpRes > 0];
if not Assigned(P) then
{Node to delete not found}
Exit;
end;
end;
{Delete the node found}
Q := P;
if (not Assigned(Q.tnPos[Right])) or (not Assigned(Q.tnPos[Left])) then begin
{Node has at most one branch}
Dec(StackP);
P := Q.tnPos[Assigned(Q.tnPos[Right])];
if StackP = 0 then
trRoot := P
else with Stack[StackP] do
Node.tnPos[Comparison > 0] := P;
end else begin
{Node has two branches; stack nodes to reach one with no right child}
P := Q.tnPos[Left];
while Assigned(P.tnPos[Right]) do begin
Inc(StackP);
with Stack[StackP] do begin
Node := P;
Comparison := 1;
end;
P := P.tnPos[Right];
end;
{Swap the node to delete with the terminal node}
TmpData := Q.Data;
Q.Data := P.Data;
Q := P;
with Stack[StackP] do begin
Node.tnPos[Comparison > 0].Data := TmpData;
Node.tnPos[Comparison > 0] := P.tnPos[Left];
end;
end;
{Dispose of the deleted node}
DisposeNodeData(Q);
Q.Free;
Dec(FCount);
{Unwind the stack and rebalance}
SubTreeDec := True;
while (StackP > 0) and SubTreeDec do begin
if StackP = 1 then
DelBalance(trRoot, SubTreeDec, Stack[1].Comparison)
else with Stack[StackP-1] do
DelBalance(Node.tnPos[Comparison > 0], SubTreeDec, Stack[StackP].Comparison);
dec(StackP);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStTree.Find(Data : Pointer) : TStTreeNode;
var
P : TStTreeNode;
CmpRes : Integer;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
P := trRoot;
while Assigned(P) do begin
CmpRes := DoCompare(Data, P.Data);
if CmpRes = 0 then begin
Result := P;
Exit;
end else
P := P.tnPos[CmpRes > 0];
end;
Result := nil;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStTree.First : TStTreeNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if Count = 0 then
Result := nil
else begin
Result := trRoot;
while Assigned(Result.tnPos[Left]) do
Result := Result.tnPos[Left];
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStTree.Insert(Data : Pointer) : TStTreeNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{Create the node}
Result := TStTreeNode(conNodeClass.Create(Data));
trInsertNode(Result);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStTree.Iterate(Action : TIterateFunc; Up : Boolean;
OtherData : Pointer) : TStTreeNode;
var
P : TStTreeNode;
Q : TStTreeNode;
StackP : Integer;
Stack : StackArray;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
StackP := 0;
P := trRoot;
repeat
while Assigned(P) do begin
Inc(StackP);
Stack[StackP].Node := P;
P := P.tnPos[not Up];
end;
if StackP = 0 then begin
Result := nil;
Exit;
end;
P := Stack[StackP].Node;
Dec(StackP);
Q := P;
P := P.tnPos[Up];
if not Action(Self, Q, OtherData) then begin
Result := Q;
Exit;
end;
until False;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStTree.Join(T: TStTree; IgnoreDups : Boolean);
begin
{$IFDEF ThreadSafe}
EnterClassCS;
EnterCS;
T.EnterCS;
try
{$ENDIF}
trIgnoreDups := IgnoreDups;
T.Iterate(JoinNode, True, Self);
T.IncNodeProtection;
T.Free;
{$IFDEF ThreadSafe}
finally
T.LeaveCS;
LeaveCS;
LeaveClassCS;
end;
{$ENDIF}
end;
function TStTree.Last : TStTreeNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if Count = 0 then
Result := nil
else begin
Result := trRoot;
while Assigned(Result.tnPos[Right]) do
Result := Result.tnPos[Right];
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStTree.Next(N : TStTreeNode) : TStTreeNode;
var
Found : Word;
P : TStTreeNode;
StackP : Integer;
Stack : StackArray;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Result := nil;
Found := 0;
StackP := 0;
P := trRoot;
repeat
while Assigned(P) do begin
Inc(StackP);
Stack[StackP].Node := P;
P := P.tnPos[Left];
end;
if StackP = 0 then
Exit;
P := Stack[StackP].Node;
Dec(StackP);
if Found = 1 then begin
Result := P;
Exit;
end;
if P = N then
Inc(Found);
P := P.tnPos[Right];
until False;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStTree.Prev(N : TStTreeNode) : TStTreeNode;
var
Found : Word;
P : TStTreeNode;
StackP : Integer;
Stack : StackArray;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Result := nil;
Found := 0;
StackP := 0;
P := trRoot;
repeat
while Assigned(P) do begin
Inc(StackP);
Stack[StackP].Node := P;
P := P.tnPos[Right];
end;
if StackP = 0 then
Exit;
P := Stack[StackP].Node;
Dec(StackP);
if Found = 1 then begin
Result := P;
Exit;
end;
if P = N then
Inc(Found);
P := P.tnPos[Left];
until False;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStTree.Split(Data : Pointer) : TStTree;
var
SR : SplitRec;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{Create and initialize the new tree}
Result := TStTreeClass(ClassType).Create(conNodeClass);
Result.Compare := Compare;
Result.OnCompare := OnCompare;
Result.DisposeData := DisposeData;
Result.OnDisposeData := OnDisposeData;
{Scan all elements to transfer some to new tree}
SR.SData := Data;
SR.STree := Result;
{Prevent SplitTree from disposing of node data it moves from old tree to new}
DisposeData := nil;
OnDisposeData := nil;
Iterate(SplitTree, True, @SR);
{Restore DisposeData property}
DisposeData := Result.DisposeData;
OnDisposeData := Result.OnDisposeData;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStTree.trInsertNode(N : TStTreeNode);
var
P : TStTreeNode;
CmpRes : Integer;
StackP : Integer;
Stack : StackArray;
SubTreeInc : Boolean;
begin
if not Assigned(N) then
Exit;
{Handle first node}
P := trRoot;
if not Assigned(P) then begin
trRoot := N;
Inc(FCount);
Exit;
end;
{Find where new node should fit in tree}
StackP := 0;
CmpRes := 0; {prevent D32 from generating a warning}
while Assigned(P) do begin
CmpRes := DoCompare(N.Data, P.Data);
if CmpRes = 0 then begin
{New node matches a node already in the tree, free it}
N.Free;
RaiseContainerError(stscDupNode);
end;
Inc(StackP);
with Stack[StackP] do begin
Node := P;
Comparison := CmpRes;
end;
P := P.tnPos[CmpRes > 0];
end;
{Insert new node}
Stack[StackP].Node.tnPos[CmpRes > 0] := N;
Inc(FCount);
{Unwind the stack and rebalance}
SubTreeInc := True;
while (StackP > 0) and SubTreeInc do begin
if StackP = 1 then
InsBalance(trRoot, SubTreeInc, Stack[1].Comparison)
else with Stack[StackP-1] do
InsBalance(Node.tnPos[Comparison > 0], SubTreeInc, Stack[StackP].Comparison);
dec(StackP);
end;
end;
procedure TStTree.LoadFromStream(S : TStream);
var
Data : pointer;
Reader : TReader;
StreamedClass : TPersistentClass;
StreamedNodeClass : TPersistentClass;
StreamedClassName : string;
StreamedNodeClassName : string;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Clear;
Reader := TReader.Create(S, 1024);
try
with Reader do
begin
StreamedClassName := ReadString;
StreamedClass := GetClass(StreamedClassName);
if (StreamedClass = nil) then
RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
(not IsOrInheritsFrom(TStTree, StreamedClass)) then
RaiseContainerError(stscWrongClass);
StreamedNodeClassName := ReadString;
StreamedNodeClass := GetClass(StreamedNodeClassName);
if (StreamedNodeClass = nil) then
RaiseContainerErrorFmt(stscUnknownNodeClass, [StreamedNodeClassName]);
if (not IsOrInheritsFrom(StreamedNodeClass, conNodeClass)) or
(not IsOrInheritsFrom(TStTreeNode, StreamedNodeClass)) then
RaiseContainerError(stscWrongNodeClass);
ReadListBegin;
while not EndOfList do
begin
Data := DoLoadData(Reader);
Insert(Data);
end;
ReadListEnd;
end;
finally
Reader.Free;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStTree.StoreToStream(S : TStream);
var
Writer : TWriter;
StoreInfo : TStoreInfo;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Writer := TWriter.Create(S, 1024);
try
with Writer do begin
WriteString(Self.ClassName);
WriteString(conNodeClass.ClassName);
WriteListBegin;
StoreInfo.Wtr := Writer;
StoreInfo.SDP := StoreData;
Iterate(StoreNode, false, @StoreInfo);
WriteListEnd;
end;
finally
Writer.Free;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
{$IFDEF ThreadSafe}
initialization
Windows.InitializeCriticalSection(ClassCritSect);
finalization
Windows.DeleteCriticalSection(ClassCritSect);
{$ENDIF}
end.

888
components/systools/source/run/stvarr.pas Normal file
View File

@ -0,0 +1,888 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StVArr.pas 4.04 *}
{*********************************************************}
{* SysTools: Virtual matrix class *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
{$I+} {trap I/O exceptions here}
{Notes:
- The virtual matrix uses a disk file for the main storage of a
two-dimensional array. A specified number of rows from the matrix can
be stored in a memory cache.
- The cache must be large enough to hold at least 2 rows. In 16-bit mode,
the cache can hold at most about 5460 rows. In 32-bit mode, the number
of cached rows is essentially unlimited.
- Normally the disk file is treated as a pure file of rows, where each
row is composed of cell columns. By overriding the HeaderSize, WriteHeader,
and ReadHeader methods, the application can use a file that has a header
prior to the array data.
- By defining a matrix of one column, the TStVMatrix class can be used
as a cache manager for any file of record.
}
unit StVArr;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
SysUtils, Classes,
StConst, StBase,
StUtils; {used for ExchangeStructs}
type
{.Z-}
TStCacheRec = record
crRow : Cardinal; {row number in cache}
crRowData : Pointer; {pointer to row buffer}
crTime : LongInt; {quasi-time last used}
crDirty : Integer; {non-zero if Row changed in memory}
end;
TStCacheArray = array[0..(StMaxBlockSize div SizeOf(TStCacheRec))-1] of TStCacheRec;
PStCacheArray = ^TStCacheArray;
{.Z-}
TStVMatrix = class(TStContainer)
{.Z+}
protected
{property instance variables}
FRows : Cardinal; {number of rows}
FCacheRows: Integer; {number of cached rows}
FCols : Cardinal; {number of columns}
FElSize : Integer; {size of each array element}
{private instance variables}
vmRowSize : LongInt; {number of bytes in a row}
vmCacheCnt : Integer; {number of used rows in cache}
vmCacheTime: LongInt; {quasi-time for LRU}
vmCache : PStCacheArray; {sorted collection of cached rows}
vmDataF : Integer; {data file}
{protected undocumented methods}
procedure ForEachUntypedVar(Action : TIterateUntypedFunc;
OtherData : pointer);
override;
procedure GetArraySizes(var RowCount, ColCount, ElSize : Cardinal);
override;
procedure SetArraySizes(RowCount, ColCount, ElSize : Cardinal);
override;
function StoresUntypedVars : boolean;
override;
procedure vmSetCacheRows(CacheRows : Integer);
procedure vmAllocateCache;
procedure vmDeallocateCache;
procedure vmInvalidateCache;
procedure vmFlushCacheNode(CacheIndex : Integer);
function vmIncCacheTime : LongInt;
function vmSearchCache(Row : Cardinal; var CacheIndex : Integer) : Boolean;
function vmGetRowData(Row : Cardinal; MakeDirty : Boolean) : Pointer;
procedure vmWriteRow(Row : Cardinal; Data : Pointer; Seek : Boolean);
procedure vmSetRows(Rows : Cardinal);
{.Z-}
public
constructor Create(Rows, Cols, ElementSize : Cardinal;
CacheRows : Integer;
const DataFile : string; OpenMode : Word); virtual;
{-Initialize a virtual 2D matrix}
destructor Destroy; override;
{-Free a virtual 2D matrix}
procedure FlushCache;
{-Write any dirty cache rows to disk}
function HeaderSize : LongInt; virtual;
{-Return the header size of the array file, default 0}
procedure WriteHeader; virtual;
{-Write a header to the array file, default none}
procedure ReadHeader; virtual;
{-Read a header from the array file, default none}
procedure Assign(Source: TPersistent); override;
{-Assign another container's contents to this one}
procedure Clear; override;
{-Fill the matrix with zeros}
procedure Fill(const Value);
{-Fill matrix with specified element value}
procedure Put(Row, Col : Cardinal; const Value);
{-Set an element}
procedure Get(Row, Col : Cardinal; var Value);
{-Return an element}
procedure PutRow(Row : Cardinal; const RowValue);
{-Set an entire row}
procedure GetRow(Row : Cardinal; var RowValue);
{-Return an entire row}
procedure ExchangeRows(Row1, Row2 : Cardinal);
{-Exchange the specified rows}
procedure SortRows(KeyCol : Cardinal; Compare : TUntypedCompareFunc);
{-Sort the array rows using the given comparison function and
the elements in the given column}
property Rows : Cardinal
{-Read or write the number of rows in the array}
read FRows
write vmSetRows;
property CacheRows : Integer
{-Read or write the number of cache rows in the array}
read FCacheRows
write vmSetCacheRows;
property Cols : Cardinal
{-Read the number of columns in the array}
read FCols;
property ElementSize : Integer
{-Read the size of each element in the array}
read FElSize;
end;
implementation
function AssignMatrixData(Container : TStContainer;
var Data;
OtherData : Pointer) : Boolean; far;
var
OurMatrix : TStVMatrix absolute OtherData;
RD : TAssignRowData absolute Data;
begin
OurMatrix.PutRow(RD.RowNum, RD.Data);
Result := true;
end;
procedure TStVMatrix.Assign(Source: TPersistent);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{The only containers that we allow to be assigned to a large matrix
are:
- a SysTools large array (TStLArray)
- a SysTools large matrix (TStLMatrix)
- another SysTools virtual matrix (TStVMatrix)}
if not AssignUntypedVars(Source, AssignMatrixData) then
inherited Assign(Source);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;{try..finally}
{$ENDIF}
end;
procedure TStVMatrix.Clear;
var
Row : Cardinal;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
vmInvalidateCache;
vmCacheCnt := 1;
with vmCache^[0] do begin
HugeFillChar(crRowData^, vmRowSize, 0);
crRow := 0;
crTime := vmIncCacheTime;
crDirty := 0;
FileSeek(vmDataF, 0, 0);
WriteHeader;
for Row := 0 to FRows-1 do
vmWriteRow(Row, crRowData, False);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStVMatrix.ForEachUntypedVar(Action : TIterateUntypedFunc;
OtherData : pointer);
var
FullRow : ^TAssignRowData;
i : Cardinal;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
GetMem(FullRow, sizeof(Cardinal) + vmRowSize);
try
for i := 0 to pred(Rows) do
begin
FullRow^.RowNum := i;
GetRow(i, FullRow^.Data);
Action(Self, FullRow^, OtherData);
end;
finally
FreeMem(FullRow, sizeof(Cardinal) + vmRowSize);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStVMatrix.GetArraySizes(var RowCount, ColCount, ElSize : Cardinal);
begin
RowCount := Rows;
ColCount := Cols;
ElSize := ElementSize;
end;
procedure TStVMatrix.SetArraySizes(RowCount, ColCount, ElSize : Cardinal);
begin
if (ColCount <> Cols) then
RaiseContainerError(stscBadColCount);
if (LongInt(ElSize) <> ElementSize) then
RaiseContainerError(stscBadElSize);
if (RowCount <> Rows) then
begin
Rows := RowCount;
end;
end;
function TStVMatrix.StoresUntypedVars : boolean;
begin
Result := true;
end;
constructor TStVMatrix.Create(Rows, Cols, ElementSize : Cardinal;
CacheRows : Integer;
const DataFile : string; OpenMode : Word);
begin
FElSize := ElementSize;
FRows := Rows;
FCols := Cols;
FCount := LongInt(Rows)*LongInt(Cols);
vmRowSize := LongInt(Cols)*LongInt(ElementSize);
FCacheRows := CacheRows;
vmDataF := -1;
CreateContainer(TStNode, 0);
if (Rows = 0) or (Cols = 0) or (ElementSize = 0) or (CacheRows < 2) or
ProductOverflow(Cols, ElementSize) or
ProductOverflow(LongInt(Cols)*LongInt(ElementSize), Rows) or
(LongInt(Cols)*LongInt(ElementSize)*LongInt(Rows) > MaxLongInt-HeaderSize) or
(CacheRows > StMaxBlockSize div SizeOf(TStCacheRec)) then
RaiseContainerError(stscBadSize);
vmAllocateCache;
{open the data file}
vmDataF := FileOpen(DataFile, OpenMode);
if vmDataF < 0 then begin
{file not found, create it}
vmDataF := FileCreate(DataFile);
if vmDataF < 0 then
RaiseContainerError(stscFileCreate)
else begin
FileClose(vmDataF);
vmDataF := FileOpen(DataFile, OpenMode);
if vmDataF < 0 then
RaiseContainerError(stscFileOpen);
{write user defined header to file}
WriteHeader;
FileSeek(vmDataF, 0, 0);
end;
end;
{read user defined header from file}
ReadHeader;
end;
destructor TStVMatrix.Destroy;
begin
if Assigned(vmCache) then begin
if vmDataF > 0 then
FlushCache;
vmDeallocateCache;
end;
if vmDataF > 0 then begin
{write user defined header to file}
FileSeek(vmDataF, 0, 0);
WriteHeader;
FileClose(vmDataF);
end;
IncNodeProtection;
inherited Destroy;
end;
procedure TStVMatrix.ExchangeRows(Row1, Row2 : Cardinal);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{$IFOPT R+}
if (Row1 >= Rows) or (Row2 >= Rows) then
RaiseContainerError(stscBadIndex);
{$ENDIF}
ExchangeStructs(vmGetRowData(Row1, True)^, vmGetRowData(Row2, True)^, vmRowSize);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStVMatrix.Fill(const Value);
var
Row : Cardinal;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
vmInvalidateCache;
vmCacheCnt := 1;
with vmCache^[0] do begin
HugeFillStruc(crRowData^, FCols, Value, FElSize);
crRow := 0;
crTime := vmIncCacheTime;
crDirty := 0;
FileSeek(vmDataF, 0, 0);
WriteHeader;
for Row := 0 to FRows-1 do
vmWriteRow(Row, crRowData, False);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStVMatrix.FlushCache;
var
I : Integer;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
for I := 0 to vmCacheCnt-1 do
vmFlushCacheNode(I);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStVMatrix.Get(Row, Col : Cardinal; var Value);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{$IFOPT R+}
if (Row >= Rows) or (Col >= Cols) then
RaiseContainerError(stscBadIndex);
{$ENDIF}
Move(PAnsiChar(vmGetRowData(Row, False))[LongInt(Col)*FElSize], Value, FElSize);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStVMatrix.GetRow(Row : Cardinal; var RowValue);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{$IFOPT R+}
if Row >= Rows then
RaiseContainerError(stscBadIndex);
{$ENDIF}
HugeMove(vmGetRowData(Row, False)^, RowValue, vmRowSize);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStVMatrix.HeaderSize : LongInt;
begin
Result := 0;
end;
procedure TStVMatrix.ReadHeader;
begin
{does nothing by default}
{can assume that FilePos = 0 when this is called}
end;
procedure TStVMatrix.Put(Row, Col : Cardinal; const Value);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{$IFOPT R+}
if (Row >= Rows) or (Col >= Cols) then
RaiseContainerError(stscBadIndex);
{$ENDIF}
Move(Value, PAnsiChar(vmGetRowData(Row, True))[LongInt(Col)*FElSize], FElSize);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStVMatrix.PutRow(Row : Cardinal; const RowValue);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{$IFOPT R+}
if Row >= Rows then
RaiseContainerError(stscBadIndex);
{$ENDIF}
HugeMove(RowValue, vmGetRowData(Row, True)^, vmRowSize);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStVMatrix.SortRows(KeyCol : Cardinal; Compare : TUntypedCompareFunc);
const
StackSize = 32;
type
Stack = array[0..StackSize-1] of LongInt;
var
L : LongInt;
R : LongInt;
PL : LongInt;
PR : LongInt;
CurEl : Pointer;
PivEl : Pointer;
StackP : Integer;
LStack : Stack;
RStack : Stack;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if KeyCol >= Cols then
RaiseContainerError(stscBadIndex);
{Need at least 2 rows to sort}
if FRows <= 1 then
Exit;
GetMem(CurEl, FElSize);
try
GetMem(PivEl, FElSize);
{Initialize the stacks}
StackP := 0;
LStack[0] := 0;
RStack[0] := FRows-1;
{Repeatedly take top partition from stack}
repeat
{Pop the stack}
L := LStack[StackP];
R := RStack[StackP];
Dec(StackP);
{Sort current partition}
repeat
{Load the pivot element}
Get((L+R) div 2, KeyCol, PivEl^);
PL := L;
PR := R;
{Swap items in sort order around the pivot index}
repeat
Get(PL, KeyCol, CurEl^);
while Compare(CurEl^, PivEl^) < 0 do begin
Inc(PL);
Get(PL, KeyCol, CurEl^);
end;
Get(PR, KeyCol, CurEl^);
while Compare(PivEl^, CurEl^) < 0 do begin
Dec(PR);
Get(PR, KeyCol, CurEl^);
end;
if PL <= PR then begin
if PL <> PR then
{Swap the two elements}
ExchangeRows(PL, PR);
Inc(PL); {assume we'll never sort 2 billion elements}
Dec(PR);
end;
until PL > PR;
{Decide which partition to sort next}
if (PR-L) < (R-PL) then begin
{Right partition is bigger}
if PL < R then begin
{Stack the request for sorting right partition}
Inc(StackP);
LStack[StackP] := PL;
RStack[StackP] := R;
end;
{Continue sorting left partition}
R := PR;
end else begin
{Left partition is bigger}
if L < PR then begin
{Stack the request for sorting left partition}
Inc(StackP);
LStack[StackP] := L;
RStack[StackP] := PR;
end;
{Continue sorting right partition}
L := PL;
end;
until L >= R;
until StackP < 0;
FreeMem(PivEl, FElSize);
finally
FreeMem(CurEl, FElSize);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStVMatrix.vmAllocateCache;
var
I : Integer;
begin
GetMem(vmCache, FCacheRows*SizeOf(TStCacheRec));
FillChar(vmCache^, FCacheRows*SizeOf(TStCacheRec), 0);
try
for I := 0 to FCacheRows-1 do
with vmCache^[I] do
HugeGetMem(crRowData, vmRowSize);
except
vmDeallocateCache;
raise;
end;
vmInvalidateCache;
end;
procedure TStVMatrix.vmDeallocateCache;
var
I : Integer;
begin
if Assigned(vmCache) then begin
for I := FCacheRows-1 downto 0 do
HugeFreeMem(vmCache^[I].crRowData, vmRowSize);
if Assigned(vmCache) then
FreeMem(vmCache, FCacheRows*SizeOf(TStCacheRec));
vmCache := nil;
end;
FCacheRows := 0;
end;
procedure TStVMatrix.vmFlushCacheNode(CacheIndex : Integer);
begin
with vmCache^[CacheIndex] do
if crDirty > 0 then begin
vmWriteRow(crRow, crRowData, True);
crDirty := 0;
end;
end;
function TStVMatrix.vmGetRowData(Row : Cardinal; MakeDirty : Boolean) : Pointer;
var
CacheIndex, OldestIndex : Integer;
OldestTime, Bytes : LongInt;
TmpRowData : Pointer;
begin
if not vmSearchCache(Row, CacheIndex) then begin
{row not found in cache}
if vmCacheCnt = FCacheRows then begin
{cache full, must throw out oldest row in cache}
OldestTime := MaxLongInt;
OldestIndex := 0; {prevent D32 from generating a warning}
for CacheIndex := 0 to vmCacheCnt-1 do
with vmCache^[CacheIndex] do
if crTime < OldestTime then begin
OldestIndex := CacheIndex;
OldestTime := crTime;
end;
vmFlushCacheNode(OldestIndex);
dec(vmCacheCnt);
TmpRowData := vmCache^[OldestIndex].crRowData;
Move(vmCache^[OldestIndex+1], vmCache^[OldestIndex],
(vmCacheCnt-OldestIndex)*SizeOf(TStCacheRec));
vmCache^[vmCacheCnt].crRowData := TmpRowData;
{find spot where row should now be inserted}
vmSearchCache(Row, CacheIndex);
end;
{add row to cache}
TmpRowData := vmCache^[vmCacheCnt].crRowData;
Move(vmCache^[CacheIndex], vmCache^[CacheIndex+1],
(vmCacheCnt-CacheIndex)*SizeOf(TStCacheRec));
inc(vmCacheCnt);
with vmCache^[CacheIndex] do begin
crRowData := TmpRowData;
crRow := Row;
Bytes := FileSeek(vmDataF, HeaderSize+LongInt(Row)*vmRowSize, 0);
if Bytes >= 0 then
Bytes := FileRead(vmDataF, crRowData^, vmRowSize);
if Bytes < 0 then
RaiseContainerError(stscFileRead);
{else if Bytes = 0 then}
{row hasn't been written to yet}
{HugeFillChar(crRowData^, vmRowSize, 0);}
crDirty := 0;
end;
end;
with vmCache^[CacheIndex] do begin
Result := crRowData;
if MakeDirty then
crDirty := 1;
crTime := vmIncCacheTime;
end;
end;
function TStVMatrix.vmIncCacheTime : LongInt;
var
I : Integer;
begin
if vmCacheTime = MaxLongInt-1 then begin
{reset time for all buffers}
for I := 0 to vmCacheCnt-1 do
vmCache^[I].crTime := 0;
vmCacheTime := 0;
end;
inc(vmCacheTime);
Result := vmCacheTime;
end;
procedure TStVMatrix.vmInvalidateCache;
begin
vmCacheCnt := 0;
vmCacheTime := 0;
end;
function TStVMatrix.vmSearchCache(Row : Cardinal; var CacheIndex : Integer) : Boolean;
var
L, R, M : Integer;
Comp : LongInt;
begin
if vmCacheCnt = 0 then begin
Result := False;
CacheIndex := 0;
Exit;
end;
{search cache for row using binary search}
L := 0;
R := vmCacheCnt-1;
repeat
M := (L+R) div 2;
with vmCache^[M] do begin
Comp := LongInt(Row)-LongInt(crRow);
if Comp = 0 then begin
{found row in cache}
Result := True;
CacheIndex := M;
Exit;
end else if Comp < 0 then
R := M-1
else
L := M+1;
end;
until L > R;
{not found, return where it should be inserted}
Result := False;
CacheIndex := M;
if Comp > 0 then
inc(CacheIndex);
end;
procedure TStVMatrix.vmSetCacheRows(CacheRows : Integer);
var
I : Integer;
NewCache : PStCacheArray;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if CacheRows = FCacheRows then
Exit;
if (CacheRows < 2) or (CacheRows > StMaxBlockSize div SizeOf(TStCacheRec)) then
RaiseContainerError(stscBadSize);
{allocate new cache descriptor array}
GetMem(NewCache, CacheRows*SizeOf(TStCacheRec));
FillChar(NewCache^, CacheRows*SizeOf(TStCacheRec), 0);
try
{allocate new buffers if any}
for I := FCacheRows to CacheRows-1 do
with NewCache^[I] do
HugeGetMem(crRowData, vmRowSize);
{transfer old cache buffers to new array}
for I := 0 to FCacheRows-1 do
if I < CacheRows then
NewCache^[I] := vmCache^[I]
else begin
{number of buffers shrunk, get rid of excess buffers}
if I < vmCacheCnt then
vmFlushCacheNode(I);
HugeFreeMem(vmCache^[I].crRowData, vmRowSize);
end;
except
for I := CacheRows-1 downto 0 do
HugeFreeMem(NewCache^[I].crRowData, vmRowSize);
FreeMem(NewCache, CacheRows*SizeOf(TStCacheRec));
end;
{update cache in-use count}
if vmCacheCnt > CacheRows then
vmCacheCnt := CacheRows;
{deallocate old cache}
FreeMem(vmCache, FCacheRows*SizeOf(TStCacheRec));
vmCache := NewCache;
FCacheRows := CacheRows;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStVMatrix.vmSetRows(Rows : Cardinal);
var
I : Integer;
NewSize : LongInt;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if Rows = FRows then
Exit;
{validate new size}
if (Rows = 0) or
ProductOverflow(Rows, Cols) or
ProductOverflow(LongInt(Rows)*LongInt(Cols), FElSize) then
RaiseContainerError(stscBadSize);
if Rows < FRows then begin
{dump now-irrelevant rows from cache}
for I := 0 to vmCacheCnt-1 do
if vmCache^[I].crRow >= Rows then begin
vmCacheCnt := I;
break;
end;
{truncate data file}
NewSize := HeaderSize+LongInt(Rows)*LongInt(Cols)*FElSize;
if FileSeek(vmDataF, 0, 2) > NewSize then begin
FileSeek(vmDataF, NewSize, 0);
{$IFDEF FPC}
if not FileTruncate(vmDataF, NewSize) then
{$ELSE}
if not SetEndOfFile(vmDataF) then
{$ENDIF}
RaiseContainerError(stscFileWrite);
end;
end;
FRows := Rows;
FileSeek(vmDataF, 0, 0);
WriteHeader;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStVMatrix.vmWriteRow(Row : Cardinal; Data : Pointer; Seek : Boolean);
var
Bytes : LongInt;
begin
if Seek then
FileSeek(vmDataF, HeaderSize+LongInt(Row)*vmRowSize, 0);
Bytes := FileWrite(vmDataF, Data^, vmRowSize);
if (Bytes < 0) or (Bytes <> vmRowSize) then
RaiseContainerError(stscFileWrite);
end;
procedure TStVMatrix.WriteHeader;
begin
{does nothing by default}
{can assume that FilePos = 0 when this is called}
end;
end.