systools: Add units StBCD and StLArr, as well as corresponding examples.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6142 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2018-01-17 09:00:33 +00:00
parent 560fd631fa
commit 50261c1f99
18 changed files with 6865 additions and 2 deletions
--- a/components/systools/examples/2d
+++ b/components/systools/examples/2d
@@ -0,0 +1,86 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <General>
+      <Flags>
+        <UseDefaultCompilerOptions Value="True"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="es2darr"/>
+      <Scaled Value="True"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <XPManifest>
+        <DpiAware Value="True"/>
+      </XPManifest>
+      <Icon Value="0"/>
+    </General>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+      <Modes Count="0"/>
+    </RunParams>
+    <RequiredPackages Count="2">
+      <Item1>
+        <PackageName Value="laz_systools"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="LCL"/>
+      </Item2>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="es2darr.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="Ex2darr"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="ex2darru.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="STDlg"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="Form"/>
+        <UnitName Value="Ex2DArrU"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="es2darr"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>
--- a/components/systools/examples/2d
+++ b/components/systools/examples/2d
@@ -0,0 +1,42 @@
+(* ***** 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 ***** *)
+
+program Ex2darr;
+
+uses
+  Interfaces,
+  Forms, lclversion,
+  ex2darru in 'ex2darru.pas' {STDlg};
+
+{$R *.res}
+
+begin
+  {$IF LCL_FULLVERSION >= 1080000}
+  Application.Scaled := True;
+  {$ENDIF}
+  Application.Initialize;
+  Application.CreateForm(TSTDlg, STDlg);
+  Application.Run;
+end.
--- a/components/systools/examples/2d
+++ b/components/systools/examples/2d
@@ -0,0 +1,182 @@
+object STDlg: TSTDlg
+  Left = 269
+  Height = 309
+  Top = 152
+  Width = 347
+  BorderStyle = bsDialog
+  Caption = 'STLMatrix Example'
+  ClientHeight = 309
+  ClientWidth = 347
+  Color = clBtnFace
+  Font.Color = clBlack
+  OnClose = FormClose
+  OnCreate = FormCreate
+  Position = poScreenCenter
+  ShowHint = True
+  LCLVersion = '1.9.0.0'
+  object Label5: TLabel
+    Left = 20
+    Height = 15
+    Top = 54
+    Width = 31
+    Caption = 'Value:'
+    ParentColor = False
+  end
+  object Label6: TLabel
+    Left = 6
+    Height = 15
+    Top = 80
+    Width = 46
+    Caption = 'Element:'
+    ParentColor = False
+  end
+  object ArrayLB: TListBox
+    Left = 196
+    Height = 277
+    Top = 10
+    Width = 127
+    ItemHeight = 0
+    OnDblClick = ArrayLBDblClick
+    TabOrder = 0
+  end
+  object CreateBtn: TButton
+    Left = 54
+    Height = 30
+    Hint = 'Create 2d array'
+    Top = 9
+    Width = 67
+    Caption = 'Create 2D'
+    OnClick = CreateBtnClick
+    TabOrder = 1
+  end
+  object LMValue: TEdit
+    Left = 56
+    Height = 23
+    Hint = 'Value?'
+    Top = 50
+    Width = 37
+    TabOrder = 2
+    Text = '100'
+  end
+  object LMRow: TEdit
+    Left = 56
+    Height = 23
+    Hint = 'Row?'
+    Top = 76
+    Width = 37
+    TabOrder = 3
+    Text = '0'
+  end
+  object LMCol: TEdit
+    Left = 104
+    Height = 23
+    Hint = 'Column?'
+    Top = 76
+    Width = 37
+    TabOrder = 4
+    Text = '0'
+  end
+  object ClearBtn: TButton
+    Left = 24
+    Height = 28
+    Hint = 'Clear array'
+    Top = 106
+    Width = 67
+    Caption = 'Clear'
+    OnClick = ClearBtnClick
+    TabOrder = 5
+  end
+  object FillBtn: TButton
+    Left = 110
+    Height = 28
+    Hint = 'Fill array with Value'
+    Top = 106
+    Width = 67
+    Caption = 'Fill'
+    OnClick = FillBtnClick
+    TabOrder = 6
+  end
+  object PutBtn: TButton
+    Left = 24
+    Height = 28
+    Hint = 'Edit Value'
+    Top = 145
+    Width = 67
+    Caption = 'Put'
+    OnClick = PutBtnClick
+    TabOrder = 7
+  end
+  object PutRowBtn: TButton
+    Left = 110
+    Height = 28
+    Hint = 'Set values in row to Value'
+    Top = 145
+    Width = 67
+    Caption = 'Put Row'
+    OnClick = PutRowBtnClick
+    TabOrder = 8
+  end
+  object GetBtn: TButton
+    Left = 24
+    Height = 28
+    Hint = 'Get Value'
+    Top = 179
+    Width = 67
+    Caption = 'Get'
+    OnClick = GetBtnClick
+    TabOrder = 9
+  end
+  object GetRowBtn: TButton
+    Left = 110
+    Height = 28
+    Hint = 'Get values in row'
+    Top = 179
+    Width = 67
+    Caption = 'Get Row'
+    OnClick = GetRowBtnClick
+    TabOrder = 10
+  end
+  object SortBtn: TButton
+    Left = 68
+    Height = 28
+    Hint = 'Sort array'
+    Top = 217
+    Width = 67
+    Caption = 'Sort'
+    OnClick = SortBtnClick
+    TabOrder = 11
+  end
+  object LoadBtn: TButton
+    Left = 24
+    Height = 28
+    Hint = 'Load from file'
+    Top = 259
+    Width = 67
+    Caption = 'Load'
+    OnClick = LoadBtnClick
+    TabOrder = 12
+  end
+  object SaveBtn: TButton
+    Left = 110
+    Height = 28
+    Hint = 'Save to file'
+    Top = 259
+    Width = 67
+    Caption = 'Save'
+    OnClick = SaveBtnClick
+    TabOrder = 13
+  end
+  object OD1: TOpenDialog
+    DefaultExt = '.2da'
+    Filter = '*.2da (Array Data)|*.2da|*.* (All files)|*.*'
+    left = 26
+    top = 228
+  end
+  object SD1: TSaveDialog
+    DefaultExt = '.2da'
+    Filter = '*.2da (Array data)|*.2da|*.* (All files)|*.*'
+    Options = [ofOverwritePrompt]
+    left = 148
+    top = 226
+  end
+end
--- a/components/systools/examples/2d
+++ b/components/systools/examples/2d
@@ -0,0 +1,410 @@
+(* ***** 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 Ex2DArrU;
+
+interface
+
+uses
+  {$IFNDEF FPC}
+  Windows, Messages,
+  {$ENDIF}
+  SysUtils, Classes, Graphics, Controls,
+  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls,
+  StConst, StUtils, StBase, StLArr;
+
+type
+  TSTDlg = class(TForm)
+    ArrayLB: TListBox;
+    CreateBtn: TButton;
+    Label5: TLabel;
+    LMValue: TEdit;
+    Label6: TLabel;
+    LMRow: TEdit;
+    LMCol: TEdit;
+    ClearBtn: TButton;
+    FillBtn: TButton;
+    PutBtn: TButton;
+    PutRowBtn: TButton;
+    GetBtn: TButton;
+    GetRowBtn: TButton;
+    SortBtn: TButton;
+    LoadBtn: TButton;
+    SaveBtn: TButton;
+    OD1: TOpenDialog;
+    SD1: TSaveDialog;
+
+    procedure FormCreate(Sender: TObject);
+    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 LoadBtnClick(Sender: TObject);
+    procedure SaveBtnClick(Sender: TObject);
+    procedure ArrayLBDblClick(Sender: TObject);
+  private
+    { Private declarations }
+  public
+    { Public declarations }
+    procedure SetBusy(B : Boolean);
+    procedure FillListBox;
+    procedure UpdateButtons(AOK : Boolean);
+  end;
+
+var
+  STDlg: TSTDlg;
+
+implementation
+
+{$R *.lfm}
+
+type
+  S10 = string[10];
+
+const
+  MaxRows = 1000;
+  MaxCols = 10;
+
+var
+  MyLMatrix : TStLMatrix;
+  LIArray : array[1..MaxCols] of LongInt;
+
+function MyArraySort(const E1, E2) : Integer; far;
+begin
+  Result := LongInt(E1) - LongInt(E2);
+end;
+
+procedure TSTDlg.UpdateButtons(AOK : Boolean);
+begin
+  ClearBtn.Enabled  := AOK;
+  FillBtn.Enabled   := AOK;
+  PutBtn.Enabled    := AOK;
+  PutRowBtn.Enabled := AOK;
+  GetBtn.Enabled    := AOK;
+  GetRowBtn.Enabled := AOK;
+  SortBtn.Enabled   := AOK;
+  SaveBtn.Enabled   := AOK;
+end;
+
+procedure TSTDlg.SetBusy(B : Boolean);
+begin
+  if B then
+    Screen.Cursor := crHourGlass
+  else
+    Screen.Cursor := crDefault;
+end;
+
+procedure TSTDlg.FormCreate(Sender: TObject);
+begin
+  RegisterClass(TStLMatrix);
+  UpdateButtons(False);
+end;
+
+procedure TSTDlg.FormClose(Sender: TObject;
+  var Action: TCloseAction);
+begin
+  MyLMatrix.Free;
+end;
+
+procedure TSTDlg.FillListBox;
+var
+  row,
+  col,
+  Value : LongInt;
+begin
+  SetBusy(True);
+  ArrayLB.Items.BeginUpdate;
+  try
+    ArrayLB.Clear;
+
+    for row := 0 to MyLMatrix.Rows-1 do
+    begin
+      for col := 0 to MyLMatrix.Cols-1 do
+      begin
+        MyLMatrix.Get(row,col,Value);
+        ArrayLB.Items.Add(IntToStr(row) + ',' +
+                          IntToStr(col) + ' = ' + IntToStr(Value));
+      end;
+    end;
+  finally
+    ArrayLB.Items.EndUpdate;
+  end;
+  SetBusy(False);
+end;
+
+
+procedure TSTDlg.CreateBtnClick(Sender: TObject);
+var
+  row,
+  col,
+  Value  : LongInt;
+begin
+  ArrayLB.Clear;
+
+  if Assigned(MyLMatrix) then
+    MyLMatrix.Free;
+
+  UpdateButtons(False);
+  MyLMatrix := TStLMatrix.Create(MaxRows,MaxCols,sizeof(LongInt));
+  MyLMatrix.ElementsStorable := True;
+
+  SetBusy(True);
+  for row := 0 to MaxRows-1 do
+  begin
+    for col := 0 to MaxCols-1 do
+    begin
+      Value := Trunc(Random(10000));
+      MyLMatrix.Put(row,col,Value);
+    end;
+  end;
+  SetBusy(False);
+
+  FillListBox;
+  UpdateButtons(True);
+
+  LMRow.Text := '0';
+  LMCol.Text := '0';
+  MyLMatrix.Get(0,0,Value);
+  LMValue.Text := IntToStr(Value);
+end;
+
+procedure TSTDlg.ClearBtnClick(Sender: TObject);
+var
+  Value : LongInt;
+begin
+  MyLMatrix.Clear;
+  ArrayLB.Clear;
+
+  LMRow.Text := '0';
+  LMCol.Text := '0';
+  MyLMatrix.Get(0,0,Value);
+  LMValue.Text := IntToStr(Value);
+end;
+
+procedure TSTDlg.FillBtnClick(Sender: TObject);
+var
+  row,
+  col,
+  Value : LongInt;
+begin
+  if (LMValue.Text = '') then
+  begin
+    ShowMessage('No value entered');
+    Exit;
+  end;
+
+  Value := StrToInt(LMValue.Text);
+  MyLMatrix.Fill(Value);
+
+  FillListBox;
+
+  row := 0;
+  col := 0;
+  LMRow.Text := IntToStr(row);
+  LMCol.Text := IntToStr(col);
+
+  MyLMatrix.Get(row, col, Value);
+  LMValue.Text := IntToStr(Value);
+
+  SetBusy(False);
+end;
+
+procedure TSTDlg.PutBtnClick(Sender: TObject);
+var
+  LBE,
+  row,
+  col,
+  Value : LongInt;
+begin
+  if (LMValue.Text = '') then
+  begin
+    ShowMessage('No value entered');
+    Exit;
+  end;
+
+  if (LMRow.Text = '') then
+    LMRow.Text := '0';
+  if (LMCol.Text = '') then
+    LMCol.Text := '0';
+
+  Value := StrToInt(LMValue.Text);
+  row := StrToInt(LMRow.Text);
+  col := StrToInt(LMCol.Text);
+  MyLMatrix.Put(row,col,Value);
+
+  LBE := (row * MaxRows) + col;
+  ArrayLB.Items[LBE] := IntToStr(row) + ',' +
+                        IntToStr(col) + ' = ' + IntToStr(Value);
+
+  row := StrToInt(LMRow.Text);
+  col := StrToInt(LMCol.Text);
+  MyLMatrix.Get(row, col, Value);
+  LMValue.Text := IntToStr(Value);
+end;
+
+procedure TSTDlg.GetBtnClick(Sender: TObject);
+var
+  LBE,
+  row,
+  col,
+  Value : LongInt;
+begin
+  if (LMValue.Text = '') then begin
+    ShowMessage('No value entered');
+    Exit;
+  end;
+
+  if (LMRow.Text = '') then
+    LMRow.Text := '0';
+  if (LMCol.Text = '') then
+    LMCol.Text := '0';
+
+  Value := StrToInt(LMValue.Text);
+  row := StrToInt(LMRow.Text);
+  col := StrToInt(LMCol.Text);
+  MyLMatrix.Get(row,col,Value);
+
+  LMRow.Text := IntToStr(row);
+  LMCol.Text := IntToStr(col);
+  LMValue.Text := IntToStr(Value);
+
+  LBE := (row * MaxCols) + col;
+  ArrayLB.ItemIndex := LBE;
+end;
+
+procedure TSTDlg.PutRowBtnClick(Sender: TObject);
+var
+  row,
+  col,
+  Value : LongInt;
+
+begin
+  if (LMValue.Text = '') then
+  begin
+    ShowMessage('No value entered');
+    Exit;
+  end;
+
+  if (LMRow.Text = '') then
+    LMRow.Text := '0';
+
+  Value := StrToInt(LMValue.Text);
+  row := StrToInt(LMRow.Text);
+
+  FillStruct(LIArray,MaxCols,Value,SizeOf(Value));
+
+  MyLMatrix.PutRow(row,LIArray);
+  FillListBox;
+
+  row := StrToInt(LMRow.Text);
+  col := 0;
+  MyLMatrix.Get(row, col, Value);
+
+  LMValue.Text := IntToStr(Value);
+  LMCol.Text := '0';
+end;
+
+procedure TSTDlg.GetRowBtnClick(Sender: TObject);
+var
+  step,
+  LIV   : LongInt;
+
+begin
+  if (LMRow.Text = '') then
+    LMRow.Text := '0';
+
+  LIV := 0;
+  FillStruct(LIArray,MaxCols,LIV,SizeOf(LIV));
+  MyLMatrix.GetRow(0,LIArray);
+
+  ArrayLB.Items.BeginUpdate;
+  try
+    ArrayLB.Clear;
+    for step := 1 to MaxCols do
+      ArrayLB.Items.Add('Col' + IntToStr(step-1) + ': ' + IntToStr(LIArray[step]));
+  finally
+    ArrayLB.Items.EndUpdate;
+  end;
+end;
+
+procedure TSTDlg.SortBtnClick(Sender: TObject);
+begin
+  MyLMatrix.SortRows(0,MyArraySort);
+  FillListBox;
+end;
+
+procedure TSTDlg.LoadBtnClick(Sender: TObject);
+begin
+  if (OD1.Execute) then
+  begin
+    if NOT (Assigned(MyLMatrix)) then
+    begin
+      UpdateButtons(False);
+      MyLMatrix := TStLMatrix.Create(MaxRows,MaxCols,sizeof(LongInt));
+      MyLMatrix.ElementsStorable := True;
+    end;
+    MyLMatrix.LoadFromFile(OD1.FileName);
+    FillListBox;
+    UpdateButtons(True);
+  end;
+end;
+
+procedure TSTDlg.SaveBtnClick(Sender: TObject);
+begin
+  if (SD1.Execute) then
+    MyLMatrix.StoreToFile(SD1.FileName);
+end;
+
+procedure TSTDlg.ArrayLBDblClick(Sender: TObject);
+var
+  row,
+  col,
+  I,
+  Value  : LongInt;
+
+begin
+  I := ArrayLB.ItemIndex;
+  row := I div MaxCols;
+  col := I mod MaxCols;
+
+  MyLMatrix.Get(row, col, Value);
+  LMRow.Text := IntToStr(row);
+  LMCol.Text := IntToStr(col);
+  LMValue.Text := IntToStr(Value);
+end;
+
+
+
+end.