diff --git a/components/systools/examples/bits/exbits.lpi b/components/systools/examples/bits/exbits.lpi
new file mode 100644
index 000000000..ab92f4b6d
--- /dev/null
+++ b/components/systools/examples/bits/exbits.lpi
@@ -0,0 +1,86 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/bits/exbits.lpr b/components/systools/examples/bits/exbits.lpr
new file mode 100644
index 000000000..e0712c3d5
--- /dev/null
+++ b/components/systools/examples/bits/exbits.lpr
@@ -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.
diff --git a/components/systools/examples/bits/exbitsu.lfm b/components/systools/examples/bits/exbitsu.lfm
new file mode 100644
index 000000000..9dd5ab9cb
--- /dev/null
+++ b/components/systools/examples/bits/exbitsu.lfm
@@ -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
diff --git a/components/systools/examples/bits/exbitsu.pas b/components/systools/examples/bits/exbitsu.pas
new file mode 100644
index 000000000..1442d656f
--- /dev/null
+++ b/components/systools/examples/bits/exbitsu.pas
@@ -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.
diff --git a/components/systools/examples/collection/excoll.lpi b/components/systools/examples/collection/excoll.lpi
new file mode 100644
index 000000000..cc723f460
--- /dev/null
+++ b/components/systools/examples/collection/excoll.lpi
@@ -0,0 +1,84 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/collection/excoll.lpr b/components/systools/examples/collection/excoll.lpr
new file mode 100644
index 000000000..5153a1cd8
--- /dev/null
+++ b/components/systools/examples/collection/excoll.lpr
@@ -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.
diff --git a/components/systools/examples/collection/excollu.lfm b/components/systools/examples/collection/excollu.lfm
new file mode 100644
index 000000000..58854cfe9
--- /dev/null
+++ b/components/systools/examples/collection/excollu.lfm
@@ -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
diff --git a/components/systools/examples/collection/excollu.pas b/components/systools/examples/collection/excollu.pas
new file mode 100644
index 000000000..332958a68
--- /dev/null
+++ b/components/systools/examples/collection/excollu.pas
@@ -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.
diff --git a/components/systools/examples/double_ended_queue/exdque.lpi b/components/systools/examples/double_ended_queue/exdque.lpi
new file mode 100644
index 000000000..c1c2d82c0
--- /dev/null
+++ b/components/systools/examples/double_ended_queue/exdque.lpi
@@ -0,0 +1,84 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/double_ended_queue/exdque.lpr b/components/systools/examples/double_ended_queue/exdque.lpr
new file mode 100644
index 000000000..3f1aaf276
--- /dev/null
+++ b/components/systools/examples/double_ended_queue/exdque.lpr
@@ -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.
diff --git a/components/systools/examples/double_ended_queue/exdqueu.lfm b/components/systools/examples/double_ended_queue/exdqueu.lfm
new file mode 100644
index 000000000..0556076c5
--- /dev/null
+++ b/components/systools/examples/double_ended_queue/exdqueu.lfm
@@ -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
diff --git a/components/systools/examples/double_ended_queue/exdqueu.pas b/components/systools/examples/double_ended_queue/exdqueu.pas
new file mode 100644
index 000000000..b7e06a149
--- /dev/null
+++ b/components/systools/examples/double_ended_queue/exdqueu.pas
@@ -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.
diff --git a/components/systools/examples/nonvisual/exnv.lpi b/components/systools/examples/nonvisual/exnv.lpi
new file mode 100644
index 000000000..a2d5768dc
--- /dev/null
+++ b/components/systools/examples/nonvisual/exnv.lpi
@@ -0,0 +1,86 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/nonvisual/exnv.lpr b/components/systools/examples/nonvisual/exnv.lpr
new file mode 100644
index 000000000..0e71119e2
--- /dev/null
+++ b/components/systools/examples/nonvisual/exnv.lpr
@@ -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.
diff --git a/components/systools/examples/nonvisual/exnvu.lfm b/components/systools/examples/nonvisual/exnvu.lfm
new file mode 100644
index 000000000..51088938e
--- /dev/null
+++ b/components/systools/examples/nonvisual/exnvu.lfm
@@ -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
diff --git a/components/systools/examples/nonvisual/exnvu.pas b/components/systools/examples/nonvisual/exnvu.pas
new file mode 100644
index 000000000..e3b586ff6
--- /dev/null
+++ b/components/systools/examples/nonvisual/exnvu.pas
@@ -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.
diff --git a/components/systools/examples/priority_queue/expq.lpi b/components/systools/examples/priority_queue/expq.lpi
new file mode 100644
index 000000000..9c49d0bdd
--- /dev/null
+++ b/components/systools/examples/priority_queue/expq.lpi
@@ -0,0 +1,85 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/priority_queue/expq.lpr b/components/systools/examples/priority_queue/expq.lpr
new file mode 100644
index 000000000..02192ecc2
--- /dev/null
+++ b/components/systools/examples/priority_queue/expq.lpr
@@ -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.
\ No newline at end of file
diff --git a/components/systools/examples/priority_queue/expqu.lfm b/components/systools/examples/priority_queue/expqu.lfm
new file mode 100644
index 000000000..020fc6e76
--- /dev/null
+++ b/components/systools/examples/priority_queue/expqu.lfm
@@ -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
diff --git a/components/systools/examples/priority_queue/expqu.pas b/components/systools/examples/priority_queue/expqu.pas
new file mode 100644
index 000000000..030c04b6d
--- /dev/null
+++ b/components/systools/examples/priority_queue/expqu.pas
@@ -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.
diff --git a/components/systools/examples/tree/extree.lpi b/components/systools/examples/tree/extree.lpi
new file mode 100644
index 000000000..e963d584e
--- /dev/null
+++ b/components/systools/examples/tree/extree.lpi
@@ -0,0 +1,86 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/tree/extree.lpr b/components/systools/examples/tree/extree.lpr
new file mode 100644
index 000000000..ebf302b48
--- /dev/null
+++ b/components/systools/examples/tree/extree.lpr
@@ -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.
diff --git a/components/systools/examples/tree/extreeu.lfm b/components/systools/examples/tree/extreeu.lfm
new file mode 100644
index 000000000..198b1c484
--- /dev/null
+++ b/components/systools/examples/tree/extreeu.lfm
@@ -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
diff --git a/components/systools/examples/tree/extreeu.pas b/components/systools/examples/tree/extreeu.pas
new file mode 100644
index 000000000..f9cc6440f
--- /dev/null
+++ b/components/systools/examples/tree/extreeu.pas
@@ -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.
diff --git a/components/systools/examples/virtual_matrix/exvarr.lpi b/components/systools/examples/virtual_matrix/exvarr.lpi
new file mode 100644
index 000000000..17f10cacc
--- /dev/null
+++ b/components/systools/examples/virtual_matrix/exvarr.lpi
@@ -0,0 +1,86 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/virtual_matrix/exvarr.lpr b/components/systools/examples/virtual_matrix/exvarr.lpr
new file mode 100644
index 000000000..4c57cea2f
--- /dev/null
+++ b/components/systools/examples/virtual_matrix/exvarr.lpr
@@ -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.
diff --git a/components/systools/examples/virtual_matrix/exvarru.lfm b/components/systools/examples/virtual_matrix/exvarru.lfm
new file mode 100644
index 000000000..836b3b341
--- /dev/null
+++ b/components/systools/examples/virtual_matrix/exvarru.lfm
@@ -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
diff --git a/components/systools/examples/virtual_matrix/exvarru.pas b/components/systools/examples/virtual_matrix/exvarru.pas
new file mode 100644
index 000000000..9ec0d331c
--- /dev/null
+++ b/components/systools/examples/virtual_matrix/exvarru.pas
@@ -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.
diff --git a/components/systools/laz_systools.lpk b/components/systools/laz_systools.lpk
index fae708501..17e744647 100644
--- a/components/systools/laz_systools.lpk
+++ b/components/systools/laz_systools.lpk
@@ -16,7 +16,7 @@
-
+
@@ -177,6 +177,70 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/laz_systools.pas b/components/systools/laz_systools.pas
index 1b54a9de2..567850aa8 100644
--- a/components/systools/laz_systools.pas
+++ b/components/systools/laz_systools.pas
@@ -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
diff --git a/components/systools/source/design/StReg.pas b/components/systools/source/design/StReg.pas
index 8abde1f19..c68df2445 100644
--- a/components/systools/source/design/StReg.pas
+++ b/components/systools/source/design/StReg.pas
@@ -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.
diff --git a/components/systools/source/run/stbits.pas b/components/systools/source/run/stbits.pas
new file mode 100644
index 000000000..91deeef84
--- /dev/null
+++ b/components/systools/source/run/stbits.pas
@@ -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.
diff --git a/components/systools/source/run/stcoll.pas b/components/systools/source/run/stcoll.pas
new file mode 100644
index 000000000..2e12f896d
--- /dev/null
+++ b/components/systools/source/run/stcoll.pas
@@ -0,0 +1,1217 @@
+// 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: StColl.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Huge, sparse collection class *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+//{$I StDefine.inc}
+
+{Notes:
+ - STCOLL generally follows the standards set by Borland's TP6
+ TCollection. All elements in the collection are pointers. Elements can
+ be inserted, deleted, and accessed by index number. The size of the
+ collection grows dynamically as needed. However, STCOLL is implemented
+ in a different fashion that gives it more capacity and higher
+ efficiency in some ways.
+
+ - STCOLL theoretically allows up to 2 billion elements. The collection
+ is "sparse" in the sense that most of the memory is allocated only
+ when a value is assigned to an element in the collection.
+
+ - STCOLL is implemented as a linked list of pointers to pages. Each
+ page can hold a fixed number of collection elements, the size
+ being specified when the TStCollection is created. Only when an
+ element with a given index is written to is a page descriptor and a
+ page allocated for it. However, the first page is allocated when the
+ collection is created.
+
+ - The larger the page size, the faster it is to access a given index
+ and the less memory overhead is used for management of the collection.
+ If the page size is at least as large as the number of elements added
+ to the collection, TStCollection works just like Borland's old
+ TCollection. Inserting elements in the middle of very large pages can
+ be slow, however, because lots of data must be shifted to make room
+ for each new element. Conversely, if the page size is 1, TStCollection
+ acts much like a traditional linked list.
+
+ - The page size is limited to 16380 elements in 16-bit mode, or
+ 536 million elements in 32-bit mode.
+
+ - STCOLL uses the DisposeData procedure of TStContainer to determine
+ how to free elements in the collection. By default, it does nothing.
+
+ - AtFree and Free do not exist in TStCollection. Instead the AtDelete
+ and Delete methods will also dispose of the element if the DisposeData
+ property of the class has been set.
+
+ - The Count property returns the index (plus one) of the highest
+ element inserted or put.
+
+ - AtInsert can insert an item at any index, even larger than Count+1.
+ AtPut also can put an item at any index.
+
+ - If the At function is called for any non-negative index whose value
+ has not been explicitly assigned using Insert or AtInsert, it returns
+ nil.
+
+ - For the non-sorted collection, IndexOf compares the data pointers
+ directly, for exact equality, without using any Comparison function.
+
+ - TStSortedCollection allows duplicate nodes only if its Duplicates
+ property is set.
+
+ - The Efficiency property returns a measure of how fully the collection
+ is using the memory pages it has allocated. It returns a number in the
+ range of 0 to 100 (percent). Calling TStSortedCollection.Insert,
+ AtInsert, Delete, or AtDelete can result in a low efficiency. After a
+ series of calls to these methods it is often worthwhile to call the
+ Pack method to increase the efficiency as much as possible.
+}
+
+unit StColl;
+{-}
+
+interface
+
+uses
+ Windows, Classes,
+
+ StConst, StBase, StList;
+
+type
+ {.Z+}
+ PPointerArray = ^TPointerArray;
+ TPointerArray = array[0..(StMaxBlockSize div SizeOf(Pointer))-1] of Pointer;
+
+ TPageDescriptor = class(TStListNode)
+ protected
+ {PageElements count is stored in inherited Data field}
+ pdPage : PPointerArray; {Pointer to page data}
+ pdStart : LongInt; {Index of first element in page}
+ pdCount : Integer; {Number of elements used in page}
+
+ public
+ constructor Create(AData : Pointer); override;
+ destructor Destroy; override;
+ end;
+ {.Z-}
+
+ TCollIterateFunc = function (Container : TStContainer;
+ Data : Pointer;
+ OtherData : Pointer) : Boolean;
+
+ TStCollection = class(TStContainer)
+ {.Z+}
+ protected
+ colPageList : TStList; {List of page descriptors}
+ colPageElements : Integer; {Number of elements in a page}
+ colCachePage : TPageDescriptor; {Page last found by At}
+
+ procedure colAdjustPagesAfter(N : TPageDescriptor; Delta : LongInt);
+ procedure colAtInsertInPage(N : TPageDescriptor; PageIndex : Integer;
+ AData : Pointer);
+ procedure colAtDeleteInPage(N : TPageDescriptor; PageIndex : Integer);
+ function colGetCount : LongInt;
+ function colGetEfficiency : Integer;
+
+ procedure ForEachPointer(Action : TIteratePointerFunc; OtherData : pointer);
+ override;
+ function StoresPointers : boolean;
+ override;
+ {.Z-}
+ public
+ constructor Create(PageElements : Integer); virtual;
+ {-Initialize a collection with given page size and allocate first page}
+ destructor Destroy; override;
+ {-Free a collection}
+
+ procedure LoadFromStream(S : TStream); override;
+ {-Load a collection's data from a stream}
+ procedure StoreToStream(S : TStream); override;
+ {-Write a collection and its data to a stream}
+
+ procedure Clear; override;
+ {-Deallocate all pages and free all items}
+ procedure Assign(Source: TPersistent); override;
+ {-Assign another container's contents to this one}
+ procedure Pack;
+ {-Squeeze collection elements into the least memory possible}
+
+ function At(Index : LongInt) : Pointer;
+ {-Return the element at a given index}
+ function IndexOf(Data : Pointer) : LongInt; virtual;
+ {-Return the index of the first item with given data}
+
+ procedure AtInsert(Index : LongInt; Data : Pointer);
+ {-Insert a new element at a given index and move following items down}
+ procedure AtPut(Index : LongInt; Data : Pointer);
+ {-Replace element at given index with new data}
+ procedure Insert(Data : Pointer); virtual;
+ {-Insert item at the end of the collection}
+
+ procedure AtDelete(Index : LongInt);
+ {-Remove element at a given index, move following items up, free element}
+ procedure Delete(Data : Pointer);
+ {-Delete the first item with the given data}
+
+ function Iterate(Action : TCollIterateFunc; Up : Boolean;
+ OtherData : Pointer) : Pointer;
+ {-Call Action for all the non-nil elements, returning the last data}
+
+ property Count : LongInt
+ {-Return the index of the highest assigned item, plus one}
+ read colGetCount;
+
+ property Efficiency : Integer
+ {-Return the overall percent Efficiency of the pages}
+ read colGetEfficiency;
+
+ property Items[Index : LongInt] : Pointer
+ {-Return the Index'th node, 0-based}
+ read At
+ write AtPut;
+ default;
+ end;
+
+ {.Z+}
+ TSCSearch = (SCSPageEmpty,
+ SCSLessThanThisPage,
+ SCSInThisPageRange,
+ SCSFound,
+ SCSGreaterThanThisPage);
+ {.Z-}
+
+ TStSortedCollection = class(TStCollection)
+ {.Z+}
+ protected
+ FDuplicates : Boolean;
+
+ function scSearchPage(AData : Pointer; N : TPageDescriptor;
+ var PageIndex : Integer) : TSCSearch;
+
+ procedure scSetDuplicates(D : Boolean);
+ {.Z-}
+ public
+ procedure LoadFromStream(S : TStream); override;
+ {-Load a sorted collection's data from a stream}
+ procedure StoreToStream(S : TStream); override;
+ {-Write a collection and its data to a stream}
+
+ function IndexOf(Data : Pointer) : LongInt; override;
+ {-Return the index of the first item with given data}
+ procedure Insert(Data : Pointer); override;
+ {-Insert item in sorted position}
+ property Duplicates : Boolean
+ {-Determine whether sorted collection allows duplicate data}
+ read FDuplicates
+ write scSetDuplicates;
+ end;
+
+{======================================================================}
+
+implementation
+
+function AssignData(Container : TStContainer;
+ Data, OtherData : Pointer) : Boolean; far;
+ var
+ OurColl : TStCollection absolute OtherData;
+ begin
+ OurColl.Insert(Data);
+ Result := true;
+ end;
+
+constructor TPageDescriptor.Create(AData : Pointer);
+begin
+ inherited Create(AData);
+ GetMem(pdPage, LongInt(Data)*SizeOf(Pointer));
+ FillChar(pdPage^, LongInt(Data)*SizeOf(Pointer), 0);
+end;
+
+destructor TPageDescriptor.Destroy;
+begin
+ if Assigned(pdPage) then
+ FreeMem(pdPage, LongInt(Data)*SizeOf(Pointer));
+ inherited Destroy;
+end;
+
+{----------------------------------------------------------------------}
+
+procedure TStCollection.Assign(Source: TPersistent);
+ begin
+ {$IFDEF ThreadSafe}
+ EnterCS;
+ try
+ {$ENDIF}
+ {The only containers that we allow to be assigned to a collection are
+ - a SysTools linked list (TStList)
+ - a SysTools binary search tree (TStTree)
+ - another SysTools collection (TStCollection, TStSortedCollection)}
+ if not AssignPointers(Source, AssignData) then
+ inherited Assign(Source);
+ {$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;{try..finally}
+ {$ENDIF}
+ end;
+
+function TStCollection.At(Index : LongInt) : Pointer;
+var
+ Start : LongInt;
+ N : TPageDescriptor;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if Index < 0 then
+ RaiseContainerError(stscBadIndex);
+
+ N := colCachePage;
+ if Index >= N.pdStart then
+ {search up}
+ repeat
+ with N do begin
+ Start := pdStart;
+ if Index < Start then begin
+ {element has not been set}
+ colCachePage := N;
+ break;
+ end else if Index < Start+pdCount then begin
+ {element is in this page}
+ colCachePage := N;
+ Result := pdPage^[Index-Start];
+ Exit;
+ end;
+ end;
+ N := TPageDescriptor(N.FNext);
+ until not Assigned(N)
+
+ else begin
+ {search down}
+ N := TPageDescriptor(N.FPrev);
+ while Assigned(N) do begin
+ with N do begin
+ Start := pdStart;
+ if (Index >= Start+pdCount) then begin
+ {element has not been set}
+ colCachePage := N;
+ break;
+ end else if Index >= Start then begin
+ {element is in this page}
+ colCachePage := N;
+ Result := pdPage^[Index-Start];
+ Exit;
+ end;
+ end;
+ N := TPageDescriptor(N.FPrev);
+ end;
+ end;
+
+ {not found, leave cache page unchanged}
+ Result := nil;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStCollection.AtDelete(Index : LongInt);
+var
+ Start : LongInt;
+ N : TPageDescriptor;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if Index < 0 then
+ RaiseContainerError(stscBadIndex);
+
+ N := colCachePage;
+ if Index >= N.pdStart then
+ repeat
+ with N do begin
+ Start := pdStart;
+ if Index < Start then begin
+ {element has not been set, nothing to free}
+ Dec(pdStart);
+ colAdjustPagesAfter(N, -1);
+ colCachePage := N;
+ Exit;
+ end else if Index < Start+pdCount then begin
+ {element is in this page}
+ colCachePage := N;
+ colAtDeleteInPage(N, Index-Start);
+ Exit;
+ end;
+ end;
+ N := TPageDescriptor(N.FNext);
+ until not Assigned(N)
+
+ else begin
+ {search down}
+ N := TPageDescriptor(N.FPrev);
+ while Assigned(N) do begin
+ with N do begin
+ Start := pdStart;
+ if Index >= Start+pdCount then begin
+ {element has not been set, nothing to free}
+ Dec(pdStart);
+ colAdjustPagesAfter(N, -1);
+ colCachePage := N;
+ Exit;
+ end else if Index >= Start then begin
+ {element is in this page}
+ colCachePage := N;
+ colAtDeleteInPage(N, Index-Start);
+ Exit;
+ end;
+ end;
+ N := TPageDescriptor(N.FPrev);
+ end;
+ end;
+
+ {index not found, nothing to delete}
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStCollection.AtInsert(Index : LongInt; Data : Pointer);
+var
+ Start : LongInt;
+ NC : Integer;
+ N : TPageDescriptor;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if Index < 0 then
+ RaiseContainerError(stscBadIndex);
+
+ N := TPageDescriptor(colPageList.Head);
+ while Assigned(N) do begin
+ Start := N.pdStart;
+ if Index < Start then begin
+ {current page has indexes greater than the specified one}
+ if Start-Index <= colPageElements-N.pdCount then begin
+ {room to squeeze element into this page}
+ NC := Start-Index;
+ Move(N.pdPage^[0], N.pdPage^[NC], N.pdCount*SizeOf(Pointer));
+ FillChar(N.pdPage^[1], (NC-1)*SizeOf(Pointer), 0);
+ Inc(N.pdCount, NC);
+ end else begin
+ {insert on a new page before this one}
+ N := TPageDescriptor(colPageList.PlaceBefore(Pointer(colPageElements), N));
+ N.pdCount := 1;
+ end;
+ N.pdStart := Index;
+ N.pdPage^[0] := Data;
+ colAdjustPagesAfter(N, +1);
+ Exit;
+ end else if Index < Start+colPageElements then
+ if (not Assigned(N.FNext)) or (Index < TPageDescriptor(N.FNext).pdStart) then begin
+ {should be inserted on this page}
+ colAtInsertInPage(N, Index-Start, Data);
+ Exit;
+ end;
+ N := TPageDescriptor(N.FNext);
+ end;
+
+ {should be inserted after all existing pages}
+ N := TPageDescriptor(colPageList.Append(Pointer(colPageElements)));
+ N.pdStart := Index;
+ N.pdCount := 1;
+ N.pdPage^[0] := Data;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStCollection.AtPut(Index : LongInt; Data : Pointer);
+var
+ Start : LongInt;
+ N, T : TPageDescriptor;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if Index < 0 then
+ RaiseContainerError(stscBadIndex);
+
+ {special case for putting to end of collection}
+ T := TPageDescriptor(colPageList.Tail);
+ if Index = T.pdStart+T.pdCount then begin
+ if T.pdCount >= colPageElements then begin
+ {last page is full, add another}
+ Start := T.pdStart+colPageElements;
+ T := TPageDescriptor(colPageList.Append(Pointer(colPageElements)));
+ T.pdStart := Start;
+ {T.pdCount := 0;}
+ end;
+ T.pdPage^[T.pdCount] := Data;
+ inc(T.pdCount);
+ Exit;
+ end;
+
+ N := colCachePage;
+ if Index >= N.pdStart then
+ {search up}
+ repeat
+ Start := N.pdStart;
+ if Index < Start then begin
+ {element has not been set before}
+ N := TPageDescriptor(colPageList.PlaceBefore(Pointer(colPageElements), N));
+ N.pdStart := Index;
+ N.pdCount := 1;
+ N.pdPage^[0] := Data;
+ colCachePage := N;
+ Exit;
+ end else if Index < Start+N.pdCount then begin
+ {element fits in this page}
+ colCachePage := N;
+ N.pdPage^[Index-Start] := Data;
+ Exit;
+ end else if (N = T) and (Index < Start+colPageElements) then begin
+ {element fits in last page}
+ colCachePage := N;
+ N.pdPage^[Index-Start] := Data;
+ N.pdCount := Index-Start+1;
+ Exit;
+ end;
+ N := TPageDescriptor(N.FNext);
+ until not Assigned(N)
+
+ else begin
+ {search down}
+ N := TPageDescriptor(N.FPrev);
+ while Assigned(N) do begin
+ Start := N.pdStart;
+ if (Index >= Start+N.pdCount) then begin
+ {element has not been set before}
+ N := TPageDescriptor(colPageList.PlaceBefore(Pointer(colPageElements), N));
+ N.pdStart := Index;
+ N.pdCount := 1;
+ N.pdPage^[0] := Data;
+ colCachePage := N;
+ Exit;
+ end else if Index >= Start then begin
+ {element is in this page}
+ colCachePage := N;
+ N.pdPage^[Index-Start] := Data;
+ Exit;
+ end;
+ N := TPageDescriptor(N.FPrev);
+ end;
+ end;
+
+ {an element after all existing ones}
+ N := TPageDescriptor(colPageList.Append(Pointer(colPageElements)));
+ colCachePage := N;
+ N.pdStart := Index;
+ N.pdCount := 1;
+ N.pdPage^[0] := Data;
+ Exit;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStCollection.Clear;
+var
+ I : Integer;
+ N, P : TPageDescriptor;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ N := TPageDescriptor(colPageList.Head);
+ colCachePage := N;
+ while Assigned(N) do begin
+ for I := 0 to N.pdCount-1 do
+ DoDisposeData(N.pdPage^[I]);
+ P := TPageDescriptor(N.FNext);
+ if N = colCachePage then begin
+ {keep the first page, which is now empty}
+ N.pdCount := 0;
+ N.pdStart := 0;
+ end else
+ {delete all other pages}
+ colPageList.Delete(N);
+ N := P;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStCollection.colAdjustPagesAfter(N : TPageDescriptor; Delta : LongInt);
+begin
+ N := TPageDescriptor(N.FNext);
+ while Assigned(N) do begin
+ inc(N.pdStart, Delta);
+ N := TPageDescriptor(N.FNext);
+ end;
+end;
+
+procedure TStCollection.colAtDeleteInPage(N : TPageDescriptor; PageIndex : Integer);
+begin
+ with N do begin
+ {free the element}
+ DoDisposeData(pdPage^[PageIndex]);
+ Move(pdPage^[PageIndex+1], pdPage^[PageIndex],
+ (colPageElements-PageIndex-1)*SizeOf(Pointer));
+ Dec(pdCount);
+ colAdjustPagesAfter(N, -1);
+ if (pdCount = 0) and (colPageList.Count > 1) then begin
+ {delete page if at least one page will remain}
+ if N = colCachePage then begin
+ colCachePage := TPageDescriptor(colPageList.Head);
+ if N = colCachePage then
+ colCachePage := TPageDescriptor(N.FNext);
+ end;
+ colPageList.Delete(N);
+ end;
+ end;
+end;
+
+procedure TStCollection.colAtInsertInPage(N : TPageDescriptor; PageIndex : Integer;
+ AData : Pointer);
+var
+ P : TPageDescriptor;
+ PC : Integer;
+begin
+ with N do
+ if pdCount >= colPageElements then begin
+ {page is full, add another}
+ P := TPageDescriptor(colPageList.Place(Pointer(colPageElements), N));
+ {new page starts with element after the new one}
+ P.pdStart := pdStart+PageIndex+1;
+ PC := colPageElements-PageIndex;
+ Move(pdPage^[PageIndex], P.pdPage^[0], PC*SizeOf(Pointer));
+ pdPage^[PageIndex] := AData;
+ pdCount := PageIndex+1;
+ P.pdCount := PC;
+ colAdjustPagesAfter(P, +1);
+ end else begin
+ {room to add on this page}
+ if pdCount > PageIndex then begin
+ Move(pdPage^[PageIndex], pdPage^[PageIndex+1], (pdCount-PageIndex)*SizeOf(Pointer));
+ colAdjustPagesAfter(N, +1);
+ inc(pdCount);
+ end else begin
+ FillChar(pdPage^[pdCount], (PageIndex-pdCount)*SizeOf(Pointer), 0);
+ colAdjustPagesAfter(N, PageIndex+1-pdCount);
+ pdCount := PageIndex+1;
+ end;
+ pdPage^[PageIndex] := AData;
+ end;
+end;
+
+function TStCollection.colGetCount : LongInt;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ with TPageDescriptor(colPageList.Tail) do
+ Result := pdStart+pdCount;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+function TStCollection.colGetEfficiency : Integer;
+var
+ Pages, ECount : LongInt;
+ N : TPageDescriptor;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ ECount := 0;
+ Pages := 0;
+ N := TPageDescriptor(colPageList.Head);
+ while Assigned(N) do begin
+ with N do begin
+ inc(Pages);
+ inc(ECount, N.pdCount);
+ end;
+ N := TPageDescriptor(N.FNext);
+ end;
+ Result := (100*ECount) div (Pages*colPageElements);
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStCollection.ForEachPointer(Action : TIteratePointerFunc;
+ OtherData : pointer);
+var
+ I : Integer;
+ N : TPageDescriptor;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ N := TPageDescriptor(colPageList.Head);
+ while Assigned(N) do begin
+ with N do
+ for I := 0 to pdCount-1 do
+ if (pdPage^[I] <> nil) then
+ if not Action(Self, pdPage^[I], OtherData) then begin
+ Exit;
+ end;
+ N := TPageDescriptor(N.FNext);
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+function TStCollection.StoresPointers : boolean;
+begin
+ Result := true;
+end;
+
+constructor TStCollection.Create(PageElements : Integer);
+begin
+ CreateContainer(TStNode, 0);
+
+ if (PageElements = 0) then
+ RaiseContainerError(stscBadSize);
+
+ colPageList := TStList.Create(TPageDescriptor);
+ colPageElements := PageElements;
+
+ {start with one empty page}
+ colPageList.Append(Pointer(colPageElements));
+ colCachePage := TPageDescriptor(colPageList.Head);
+end;
+
+procedure TStCollection.Delete(Data : Pointer);
+var
+ Index : LongInt;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ Index := IndexOf(Data);
+ if Index >= 0 then
+ AtDelete(Index);
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+destructor TStCollection.Destroy;
+begin
+ Clear;
+ colPageList.Free;
+ IncNodeProtection;
+ inherited Destroy;
+end;
+
+function TStCollection.IndexOf(Data : Pointer) : LongInt;
+var
+ I : LongInt;
+ N : TPageDescriptor;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ N := TPageDescriptor(colPageList.Head);
+ while Assigned(N) do begin
+ for I := 0 to N.pdCount-1 do
+ if N.pdPage^[I] = Data then begin
+ colCachePage := N;
+ Result := N.pdStart+I;
+ Exit;
+ end;
+ N := TPageDescriptor(N.FNext);
+ end;
+ IndexOf := -1;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStCollection.Insert(Data : Pointer);
+var
+ Start : LongInt;
+ N : TPageDescriptor;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ N := TPageDescriptor(colPageList.Tail);
+ if N.pdCount >= colPageElements then begin
+ {last page is full, add another}
+ Start := N.pdStart+colPageElements;
+ N := TPageDescriptor(colPageList.Append(Pointer(colPageElements)));
+ N.pdStart := Start;
+ {N.pdCount := 0;}
+ end;
+ N.pdPage^[N.pdCount] := Data;
+ inc(N.pdCount);
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+function TStCollection.Iterate(Action : TCollIterateFunc; Up : Boolean;
+ OtherData : Pointer) : Pointer;
+var
+ I : Integer;
+ N : TPageDescriptor;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if Up then begin
+ N := TPageDescriptor(colPageList.Head);
+ while Assigned(N) do begin
+ with N do
+ for I := 0 to pdCount-1 do
+ if (pdPage^[I] <> nil) then
+ if not Action(Self, pdPage^[I], OtherData) then begin
+ Result := pdPage^[I];
+ Exit;
+ end;
+ N := TPageDescriptor(N.FNext);
+ end;
+ end else begin
+ N := TPageDescriptor(colPageList.Tail);
+ while Assigned(N) do begin
+ with N do
+ for I := pdCount-1 downto 0 do
+ if (pdPage^[I] <> nil) then
+ if not Action(Self, pdPage^[I], OtherData) then begin
+ Result := pdPage^[I];
+ Exit;
+ end;
+ N := TPageDescriptor(N.FPrev);
+ end;
+ end;
+
+ Result := nil;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStCollection.Pack;
+var
+ N, P : TPageDescriptor;
+ NC : Integer;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ colCachePage := TPageDescriptor(colPageList.Head);
+ N := colCachePage;
+ while Assigned(N) do begin
+ while Assigned(N.FNext) and (N.pdCount < colPageElements) do begin
+ {there is a page beyond this page and room to add to this page}
+ P := TPageDescriptor(N.FNext);
+ if N.pdStart+N.pdCount = P.pdStart then begin
+ {next page has contiguous elements}
+ NC := colPageElements-N.pdCount;
+ if NC > P.pdCount then
+ NC := P.pdCount;
+ move(P.pdPage^[0], N.pdPage^[N.pdCount], NC*SizeOf(Pointer));
+ move(P.pdPage^[NC], P.pdPage^[0], (P.pdCount-NC)*SizeOf(Pointer));
+ inc(N.pdCount, NC);
+ dec(P.pdCount, NC);
+ if P.pdCount = 0 then
+ colPageList.Delete(P)
+ else
+ inc(P.pdStart, NC);
+ end else
+ {pages aren't contiguous, can't merge}
+ break;
+ end;
+ N := TPageDescriptor(N.FNext);
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStCollection.LoadFromStream(S : TStream);
+var
+ Data : pointer;
+ Reader : TReader;
+ PageElements : integer;
+ Index : longint;
+ StreamedClass : TPersistentClass;
+ StreamedClassName : string;
+begin
+ 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(TStCollection, StreamedClass)) then
+ RaiseContainerError(stscWrongClass);
+ PageElements := ReadInteger;
+ if (PageElements <> colPageElements) then
+ begin
+ colPageList.Clear;
+ colPageElements := PageElements;
+ colPageList.Append(Pointer(colPageElements));
+ colCachePage := TPageDescriptor(colPageList.Head);
+ end;
+ ReadListBegin;
+ while not EndOfList do
+ begin
+ Index := ReadInteger;
+ Data := DoLoadData(Reader);
+ AtPut(Index, Data);
+ end;
+ ReadListEnd;
+ end;
+ finally
+ Reader.Free;
+ end;
+end;
+
+procedure TStCollection.StoreToStream(S : TStream);
+var
+ Writer : TWriter;
+ N : TPageDescriptor;
+ i : integer;
+begin
+ Writer := TWriter.Create(S, 1024);
+ try
+ with Writer do
+ begin
+ WriteString(Self.ClassName);
+ WriteInteger(colPageElements);
+ WriteListBegin;
+ N := TPageDescriptor(colPageList.Head);
+ while Assigned(N) do
+ begin
+ with N do
+ for i := 0 to pdCount-1 do
+ if (pdPage^[i] <> nil) then
+ begin
+ WriteInteger(pdStart + i);
+ DoStoreData(Writer, pdPage^[i]);
+ end;
+ N := TPageDescriptor(N.FNext);
+ end;
+ WriteListEnd;
+ end;
+ finally
+ Writer.Free;
+ end;
+end;
+
+{----------------------------------------------------------------------}
+
+function TStSortedCollection.IndexOf(Data : Pointer) : LongInt;
+var
+ N : TPageDescriptor;
+ PageIndex : Integer;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (Count = 0) then begin
+ Result := -1;
+ Exit;
+ end;
+ N := colCachePage;
+ if DoCompare(Data, N.pdPage^[0]) >= 0 then begin
+ {search up}
+ repeat
+ case scSearchPage(Data, N, PageIndex) of
+ SCSFound :
+ begin
+ colCachePage := N;
+ Result := N.pdStart+PageIndex;
+ Exit;
+ end;
+ SCSGreaterThanThisPage :
+ {keep on searching} ;
+ else
+ {can't be anywhere else in the collection}
+ break;
+ end;
+ N := TPageDescriptor(N.FNext);
+ until not Assigned(N);
+
+ end else begin
+ {search down}
+ N := TPageDescriptor(N.FPrev);
+ while Assigned(N) do begin
+ case scSearchPage(Data, N, PageIndex) of
+ SCSFound :
+ begin
+ colCachePage := N;
+ Result := N.pdStart+PageIndex;
+ Exit;
+ end;
+ SCSLessThanThisPage :
+ {keep on searching} ;
+ else
+ {can't be anywhere else in the collection}
+ break;
+ end;
+ N := TPageDescriptor(N.FPrev);
+ end;
+ end;
+
+ Result := -1;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStSortedCollection.Insert(Data : Pointer);
+var
+ N : TPageDescriptor;
+ PageIndex : Integer;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ N := TPageDescriptor(colPageList.Head);
+ while Assigned(N) do begin
+ case scSearchPage(Data, N, PageIndex) of
+ SCSPageEmpty, SCSInThisPageRange, SCSLessThanThisPage :
+ begin
+ colAtInsertInPage(N, PageIndex, Data);
+ Exit;
+ end;
+ SCSFound :
+ if FDuplicates then begin
+ colAtInsertInPage(N, PageIndex, Data);
+ Exit;
+ end else
+ RaiseContainerError(stscDupNode);
+ end;
+ N := TPageDescriptor(N.FNext);
+ end;
+
+ {greater than all other items}
+ inherited Insert(Data);
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+function TStSortedCollection.scSearchPage(AData : Pointer; N : TPageDescriptor;
+ var PageIndex : Integer) : TSCSearch;
+var
+ L, R, M, Comp : Integer;
+begin
+ with N do
+ if pdCount = 0 then begin
+ Result := SCSPageEmpty;
+ PageIndex := 0;
+ end else if DoCompare(AData, pdPage^[0]) < 0 then begin
+ Result := SCSLessThanThisPage;
+ PageIndex := 0;
+ end else if DoCompare(AData, pdPage^[pdCount-1]) > 0 then
+ Result := SCSGreaterThanThisPage
+ else begin
+ {data might be in this page, check using binary search}
+ Result := SCSInThisPageRange;
+ L := 0;
+ R := pdCount-1;
+ repeat
+ M := (L+R) div 2;
+ Comp := DoCompare(AData, pdPage^[M]);
+ if Comp > 0 then
+ L := M+1
+ else begin
+ R := M-1;
+ if Comp = 0 then begin
+ PageIndex := M;
+ Result := SCSFound;
+ if not FDuplicates then
+ {force exit from repeat loop}
+ L := M;
+ {else loop to find first of a group of duplicate nodes}
+ end;
+ end;
+ until L > R;
+
+ if Result = SCSInThisPageRange then begin
+ {not found in page, return where it would be inserted}
+ PageIndex := M;
+ if Comp > 0 then
+ inc(PageIndex);
+ end;
+end;
+end;
+
+procedure TStSortedCollection.scSetDuplicates(D : Boolean);
+begin
+ if FDuplicates <> D then
+ if D then
+ FDuplicates := True
+ else if FCount <> 0 then
+ RaiseContainerError(stscBadDups)
+ else
+ FDuplicates := False;
+end;
+
+procedure TStSortedCollection.LoadFromStream(S : TStream);
+var
+ Data : pointer;
+ Reader : TReader;
+ PageElements : integer;
+ StreamedClass : TPersistentClass;
+ StreamedClassName : string;
+begin
+ 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(TStCollection, StreamedClass)) then
+ RaiseContainerError(stscWrongClass);
+ PageElements := ReadInteger;
+ if (PageElements <> colPageElements) then
+ begin
+ colPageList.Clear;
+ colPageElements := PageElements;
+ colPageList.Append(Pointer(colPageElements));
+ colCachePage := TPageDescriptor(colPageList.Head);
+ end;
+ FDuplicates := ReadBoolean;
+ ReadListBegin;
+ while not EndOfList do
+ begin
+ ReadInteger; {read & discard index number}
+ Data := DoLoadData(Reader);
+ Insert(Data);
+ end;
+ ReadListEnd;
+ end;
+ finally
+ Reader.Free;
+ end;
+end;
+
+procedure TStSortedCollection.StoreToStream(S : TStream);
+var
+ Writer : TWriter;
+ N : TPageDescriptor;
+ i : integer;
+begin
+ Writer := TWriter.Create(S, 1024);
+ try
+ with Writer do
+ begin
+ WriteString(Self.ClassName);
+ WriteInteger(colPageElements);
+ WriteBoolean(FDuplicates);
+ WriteListBegin;
+ N := TPageDescriptor(colPageList.Head);
+ while Assigned(N) do
+ begin
+ with N do
+ for i := 0 to pdCount-1 do
+ if (pdPage^[i] <> nil) then
+ begin
+ WriteInteger(pdStart + i);
+ DoStoreData(Writer, pdPage^[i]);
+ end;
+ N := TPageDescriptor(N.FNext);
+ end;
+ WriteListEnd;
+ end;
+ finally
+ Writer.Free;
+ end;
+end;
+
+
+end.
diff --git a/components/systools/source/run/stdque.pas b/components/systools/source/run/stdque.pas
new file mode 100644
index 000000000..a7cc24474
--- /dev/null
+++ b/components/systools/source/run/stdque.pas
@@ -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.
diff --git a/components/systools/source/run/stnvbits.pas b/components/systools/source/run/stnvbits.pas
new file mode 100644
index 000000000..429a7863e
--- /dev/null
+++ b/components/systools/source/run/stnvbits.pas
@@ -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.
diff --git a/components/systools/source/run/stnvcoll.pas b/components/systools/source/run/stnvcoll.pas
new file mode 100644
index 000000000..f1bd323fc
--- /dev/null
+++ b/components/systools/source/run/stnvcoll.pas
@@ -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.
diff --git a/components/systools/source/run/stnvcont.pas b/components/systools/source/run/stnvcont.pas
new file mode 100644
index 000000000..cb6a26bbe
--- /dev/null
+++ b/components/systools/source/run/stnvcont.pas
@@ -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.
diff --git a/components/systools/source/run/stnvdict.pas b/components/systools/source/run/stnvdict.pas
new file mode 100644
index 000000000..1ff68bec5
--- /dev/null
+++ b/components/systools/source/run/stnvdict.pas
@@ -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.
diff --git a/components/systools/source/run/stnvdq.pas b/components/systools/source/run/stnvdq.pas
new file mode 100644
index 000000000..f20c1a48e
--- /dev/null
+++ b/components/systools/source/run/stnvdq.pas
@@ -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.
diff --git a/components/systools/source/run/stnvlary.pas b/components/systools/source/run/stnvlary.pas
new file mode 100644
index 000000000..8226cf8ef
--- /dev/null
+++ b/components/systools/source/run/stnvlary.pas
@@ -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.
diff --git a/components/systools/source/run/stnvlist.pas b/components/systools/source/run/stnvlist.pas
new file mode 100644
index 000000000..b188dede6
--- /dev/null
+++ b/components/systools/source/run/stnvlist.pas
@@ -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.
diff --git a/components/systools/source/run/stnvlmat.pas b/components/systools/source/run/stnvlmat.pas
new file mode 100644
index 000000000..74ed9a2c0
--- /dev/null
+++ b/components/systools/source/run/stnvlmat.pas
@@ -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.
diff --git a/components/systools/source/run/stnvscol.pas b/components/systools/source/run/stnvscol.pas
new file mode 100644
index 000000000..14475adc9
--- /dev/null
+++ b/components/systools/source/run/stnvscol.pas
@@ -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.
diff --git a/components/systools/source/run/stnvtree.pas b/components/systools/source/run/stnvtree.pas
new file mode 100644
index 000000000..eba2f0966
--- /dev/null
+++ b/components/systools/source/run/stnvtree.pas
@@ -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.
diff --git a/components/systools/source/run/stpqueue.pas b/components/systools/source/run/stpqueue.pas
new file mode 100644
index 000000000..ead447900
--- /dev/null
+++ b/components/systools/source/run/stpqueue.pas
@@ -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.
diff --git a/components/systools/source/run/sttree.pas b/components/systools/source/run/sttree.pas
new file mode 100644
index 000000000..5b1ec02ca
--- /dev/null
+++ b/components/systools/source/run/sttree.pas
@@ -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.
diff --git a/components/systools/source/run/stvarr.pas b/components/systools/source/run/stvarr.pas
new file mode 100644
index 000000000..32b593758
--- /dev/null
+++ b/components/systools/source/run/stvarr.pas
@@ -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.