From 50261c1f99340d2efbfe72d5affa7db78d105c86 Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Wed, 17 Jan 2018 09:00:33 +0000 Subject: [PATCH] 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 --- .../systools/examples/1d array/ex1darr.lpi | 84 + .../systools/examples/1d array/ex1darr.lpr | 46 + .../systools/examples/1d array/ex1darru.lfm | 221 ++ .../systools/examples/1d array/ex1darru.pas | 393 +++ .../systools/examples/2d array/es2darr.lpi | 86 + .../systools/examples/2d array/es2darr.lpr | 42 + .../systools/examples/2d array/ex2darru.lfm | 182 ++ .../systools/examples/2d array/ex2darru.pas | 410 +++ .../examples/bcd_calculator/bcdcalc.lpi | 86 + .../examples/bcd_calculator/bcdcalc.lpr | 42 + .../examples/bcd_calculator/bcdcalu.lfm | 358 ++ .../examples/bcd_calculator/bcdcalu.pas | 534 +++ components/systools/laz_systools.lpk | 10 +- components/systools/laz_systools.pas | 2 +- components/systools/source/design/StReg.pas | 2 + .../source/run/{StBase.pas => stbase.pas} | 0 components/systools/source/run/stbcd.pas | 2906 +++++++++++++++++ components/systools/source/run/stlarr.pas | 1463 +++++++++ 18 files changed, 6865 insertions(+), 2 deletions(-) create mode 100644 components/systools/examples/1d array/ex1darr.lpi create mode 100644 components/systools/examples/1d array/ex1darr.lpr create mode 100644 components/systools/examples/1d array/ex1darru.lfm create mode 100644 components/systools/examples/1d array/ex1darru.pas create mode 100644 components/systools/examples/2d array/es2darr.lpi create mode 100644 components/systools/examples/2d array/es2darr.lpr create mode 100644 components/systools/examples/2d array/ex2darru.lfm create mode 100644 components/systools/examples/2d array/ex2darru.pas create mode 100644 components/systools/examples/bcd_calculator/bcdcalc.lpi create mode 100644 components/systools/examples/bcd_calculator/bcdcalc.lpr create mode 100644 components/systools/examples/bcd_calculator/bcdcalu.lfm create mode 100644 components/systools/examples/bcd_calculator/bcdcalu.pas rename components/systools/source/run/{StBase.pas => stbase.pas} (100%) create mode 100644 components/systools/source/run/stbcd.pas create mode 100644 components/systools/source/run/stlarr.pas diff --git a/components/systools/examples/1d array/ex1darr.lpi b/components/systools/examples/1d array/ex1darr.lpi new file mode 100644 index 000000000..b45fc4c94 --- /dev/null +++ b/components/systools/examples/1d array/ex1darr.lpi @@ -0,0 +1,84 @@ + + + + + + + + + + + + + <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="ex1darr.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="Ex1darr"/> + </Unit0> + <Unit1> + <Filename Value="ex1darru.pas"/> + <IsPartOfProject Value="True"/> + <HasResources Value="True"/> + <UnitName Value="Ex1DArrU"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="ex1darr"/> + </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> diff --git a/components/systools/examples/1d array/ex1darr.lpr b/components/systools/examples/1d array/ex1darr.lpr new file mode 100644 index 000000000..1820166fc --- /dev/null +++ b/components/systools/examples/1d array/ex1darr.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 Ex1darr; + +uses + Interfaces, + Forms, lclversion, + ex1darru in 'ex1darru.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/1d array/ex1darru.lfm b/components/systools/examples/1d array/ex1darru.lfm new file mode 100644 index 000000000..94437884a --- /dev/null +++ b/components/systools/examples/1d array/ex1darru.lfm @@ -0,0 +1,221 @@ +object STDlg: TSTDlg + Left = 261 + Height = 353 + Top = 128 + Width = 297 + BorderStyle = bsDialog + Caption = 'STLARR Example' + ClientHeight = 353 + ClientWidth = 297 + Color = clBtnFace + Font.Color = clBlack + OnClose = FormClose + OnCreate = FormCreate + Position = poScreenCenter + ShowHint = True + LCLVersion = '1.9.0.0' + object Label4: TLabel + Left = 8 + Height = 15 + Top = 64 + Width = 46 + Caption = 'Element:' + ParentColor = False + end + object Label1: TLabel + Left = 8 + Height = 15 + Top = 294 + Width = 38 + Caption = 'Name1' + ParentColor = False + end + object Label2: TLabel + Left = 8 + Height = 15 + Top = 326 + Width = 38 + Caption = 'Name2' + ParentColor = False + end + object Label3: TLabel + Left = 168 + Height = 15 + Top = 276 + Width = 7 + Caption = 'X' + ParentColor = False + end + object Label5: TLabel + Left = 168 + Height = 15 + Top = 302 + Width = 7 + Caption = 'Y' + ParentColor = False + end + object Label6: TLabel + Left = 168 + Height = 15 + Top = 326 + Width = 24 + Caption = 'Mag' + ParentColor = False + end + object CreateBtn: TButton + Left = 42 + Height = 30 + Hint = 'Create 1D array' + Top = 17 + Width = 67 + Caption = 'Create' + OnClick = CreateBtnClick + TabOrder = 0 + end + object ElemNum: TEdit + Left = 60 + Height = 23 + Hint = 'Element #?' + Top = 60 + Width = 37 + TabOrder = 1 + Text = '0' + end + object ClearBtn: TButton + Left = 6 + Height = 30 + Hint = 'Clear array' + Top = 88 + Width = 67 + Caption = 'Clear' + OnClick = ClearBtnClick + TabOrder = 2 + end + object FillBtn: TButton + Left = 80 + Height = 30 + Hint = 'Fill with Value' + Top = 88 + Width = 67 + Caption = 'Fill' + OnClick = FillBtnClick + TabOrder = 3 + end + object PutBtn: TButton + Left = 80 + Height = 30 + Hint = 'Edit Value' + Top = 127 + Width = 67 + Caption = 'Put' + OnClick = PutBtnClick + TabOrder = 5 + end + object GetBtn: TButton + Left = 6 + Height = 30 + Hint = 'Get Value' + Top = 127 + Width = 67 + Caption = 'Get' + OnClick = GetBtnClick + TabOrder = 4 + end + object SortBtn: TButton + Left = 42 + Height = 30 + Hint = 'Sort array' + Top = 169 + Width = 67 + Caption = 'Sort' + OnClick = SortBtnClick + TabOrder = 6 + end + object LB1: TListBox + Left = 162 + Height = 245 + Hint = 'DblClk displays data of selected item' + Top = 18 + Width = 127 + ItemHeight = 0 + OnDblClick = LB1DblClick + TabOrder = 9 + end + object Edit1: TEdit + Left = 56 + Height = 23 + Hint = 'Enter Up to 10 chars' + Top = 290 + Width = 83 + MaxLength = 10 + TabOrder = 10 + end + object Edit2: TEdit + Left = 56 + Height = 23 + Hint = 'Enter Up to 10 chars' + Top = 322 + Width = 83 + MaxLength = 10 + TabOrder = 11 + end + object Edit3: TEdit + Left = 198 + Height = 23 + Hint = 'Enter LongInt value' + Top = 274 + Width = 57 + TabOrder = 12 + end + object Edit4: TEdit + Left = 198 + Height = 23 + Hint = 'Enter LongInt value' + Top = 298 + Width = 57 + TabOrder = 13 + end + object Edit5: TEdit + Left = 198 + Height = 23 + Hint = 'Enter Real value' + Top = 322 + Width = 57 + TabOrder = 14 + end + object LoadBtn: TButton + Left = 6 + Height = 30 + Hint = 'Load from file' + Top = 219 + Width = 67 + Caption = 'Load' + OnClick = LoadBtnClick + TabOrder = 7 + end + object SaveBtn: TButton + Left = 80 + Height = 30 + Hint = 'Save to file' + Top = 219 + Width = 67 + Caption = 'Save' + OnClick = SaveBtnClick + TabOrder = 8 + end + object OD1: TOpenDialog + Title = 'Load Array Data' + DefaultExt = '.1da' + Filter = '*.1da (Array Files)|*.1da|*.* (All Files)|*.*' + left = 200 + top = 64 + end + object SD1: TSaveDialog + Title = 'Save Array Data' + DefaultExt = '.1da' + Filter = '*.1da (Array Files)|*.1da|*.* (All Files)|*.*' + Options = [ofOverwritePrompt] + left = 200 + top = 144 + end +end diff --git a/components/systools/examples/1d array/ex1darru.pas b/components/systools/examples/1d array/ex1darru.pas new file mode 100644 index 000000000..61ee34c7e --- /dev/null +++ b/components/systools/examples/1d array/ex1darru.pas @@ -0,0 +1,393 @@ +(* ***** 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 Ex1DArrU; + +interface + +uses + {$IFNDEF FPC} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Buttons, ExtCtrls, + StConst, StBase, StLArr; + +type + ARecord = record + X, Y : LongInt; + Mag : Double; + Name1 : string[10]; + Name2 : string[10]; + end; + +type + TSTDlg = class(TForm) + CreateBtn: TButton; + ElemNum: TEdit; + ClearBtn: TButton; + FillBtn: TButton; + PutBtn: TButton; + GetBtn: TButton; + SortBtn: TButton; + LB1: TListBox; + Label4: TLabel; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + Label5: TLabel; + Label6: TLabel; + Edit1: TEdit; + Edit2: TEdit; + Edit3: TEdit; + 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 FillBtnClick(Sender: TObject); + procedure PutBtnClick(Sender: TObject); + procedure GetBtnClick(Sender: TObject); + procedure SortBtnClick(Sender: TObject); + procedure LB1DblClick(Sender: TObject); + procedure LoadBtnClick(Sender: TObject); + procedure SaveBtnClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + MyLArray : TStLArray; + ARec : ARecord; + + procedure SetBusy(B : Boolean); + procedure FillControls; + procedure FillListBox; + function CheckControls(var AR : ARecord) : Boolean; + procedure UpdateButtons(AOK : Boolean); + end; + +var + STDlg: TSTDlg; + +implementation + +{$R *.lfm} + + +procedure TSTDlg.FormCreate(Sender: TObject); +begin + RegisterClass(TStLArray); + UpdateButtons(False); +end; + +procedure TSTDlg.FormClose(Sender: TObject; + var Action: TCloseAction); +begin + MyLArray.Free; +end; + +procedure TSTDlg.SetBusy(B : Boolean); +begin + if B then + Screen.Cursor := crHourGlass + else + Screen.Cursor := crDefault; +end; + + +function MyArraySort(const El1, El2) : Integer; far; +var + R1, R2 : ARecord; +begin + R1 := ARecord(El1); + R2 := ARecord(El2); + + Result := (R1.X-R2.X); + if Result = 0 then + Result := (R1.Y-R2.Y); + if Result = 0 then + Result := Trunc(R1.Mag-R2.Mag); + if Result = 0 then + Result := CompareText(R1.Name1,R2.Name1); + if Result = 0 then + Result := CompareText(R1.Name2,R2.Name2); +end; + +procedure TSTDlg.FillControls; +begin + with ARec do + begin + Edit1.Text := Name1; + Edit2.Text := Name2; + Edit3.Text := IntToStr(X); + Edit4.Text := IntToStr(Y); + Edit5.Text := FloatToStr(Mag); + end; +end; + +procedure TSTDlg.FillListBox; +var + step : integer; +begin + SetBusy(True); + LB1.Items.BeginUpdate; + try + LB1.Clear; + for step := 0 to MyLArray.Count-1 do + begin + MyLArray.Get(step,ARec); + LB1.Items.Add(IntToStr(ARec.X) + ', ' + IntToStr(ARec.Y)); + end; + finally + LB1.Items.EndUpdate; + end; + MyLArray.Get(0,ARec); + SetBusy(False); +end; + +function TSTDlg.CheckControls(var AR : ARecord) : Boolean; +var + C, + IV : Integer; + IR : Single; + +begin + Result := False; + + if (Edit1.Text = '') OR + (Edit2.Text = '') OR + (Edit3.Text = '') OR + (Edit4.Text = '') OR + (Edit5.Text = '') then + Exit; + + AR.Name1 := Edit1.Text; + AR.Name2 := Edit2.Text; + + Val(Edit3.Text,IV,C); + if (C<>0) then + Exit + else + AR.X := IV; + + Val(Edit4.Text,IV,C); + if (C<>0) then + Exit + else + AR.Y := IV; + + Val(Edit5.Text,IR,C); + if (C<>0) then + Exit + else + AR.Mag := IR; + Result := True; +end; + +procedure TSTDlg.UpdateButtons(AOK : Boolean); +begin + ClearBtn.Enabled := AOK; + FillBtn.Enabled := AOK; + GetBtn.Enabled := AOK; + PutBtn.Enabled := AOK; + SortBtn.Enabled := AOK; + SaveBtn.Enabled := AOK; +end; + +procedure TSTDlg.CreateBtnClick(Sender: TObject); +var + step, + I, J, + Value : LongInt; +begin + LB1.Clear; + SetBusy(True); + + if Assigned(MyLArray) then + MyLArray.Free; + + UpdateButtons(False); + MyLArray := TStLArray.Create(5000, sizeof(ARec)); + + MyLArray.ElementsStorable := True; + MyLArray.Clear; + + Randomize; + LB1.Items.BeginUpdate; + try; + Value := MyLArray.Count; + + for step := 0 to Value-1 do + begin + with ARec do begin + Name1 := ''; + Name2 := ''; + for I := 1 to 10 do begin + J := Random(26) + Ord('A'); + Name1 := Name1+ Chr(J); + J := Random(26) + Ord('A'); + Name2 := Name2 + Chr(J); + end; + + X := Trunc(Random(1000)); + Y := Trunc(Random(1000)); + Mag := Sqrt(Random(25000)); + + MyLArray.Put(step,ARec); + + LB1.Items.Add(IntToStr(ARec.X) + ', ' + IntToStr(ARec.Y)); + end; + end; + finally + LB1.Items.EndUpdate; + end; + + ElemNum.Text := '0'; + MyLArray.Get(0,ARec); + FillControls; + UpdateButtons(True); + SetBusy(False); +end; + + +procedure TSTDlg.ClearBtnClick(Sender: TObject); +begin + MyLArray.Clear; + LB1.Clear; + + ElemNum.Text := '0'; + MyLArray.Get(0,ARec); + FillControls; +end; + +procedure TSTDlg.FillBtnClick(Sender: TObject); +begin + if NOT CheckControls(ARec) then + begin + ShowMessage('One or more invalid entries'); + Exit; + end; + + MyLArray.Fill(ARec); + + FillListBox; + ElemNum.Text := '0'; + MyLArray.Get(0,ARec); + FillControls; +end; + +procedure TSTDlg.PutBtnClick(Sender: TObject); +var + E : LongInt; +begin + if (ElemNum.Text = '') then + ElemNum.Text := '0'; + + if NOT CheckControls(ARec) then + begin + ShowMessage('One or more invalid entries'); + Exit; + end; + + E := StrToInt(ElemNum.Text); + MyLArray.Put(E,ARec); + + LB1.Items[E] := IntToStr(ARec.X) + ', ' + IntToStr(ARec.Y); + + MyLArray.Get(E,ARec); + FillControls; +end; + + +procedure TSTDlg.GetBtnClick(Sender: TObject); +var + E : LongInt; +begin + if (ElemNum.Text = '') then + ElemNum.Text := '0'; + + E := StrToInt(ElemNum.Text); + MyLArray.Get(E,ARec); + + FillControls; +end; + +procedure TSTDlg.SortBtnClick(Sender: TObject); +begin + SetBusy(True); + MyLArray.Sort(MyArraySort); + SetBusy(False); + + FillListBox; + FillControls; + SetBusy(False); +end; + +procedure TSTDlg.LB1DblClick(Sender: TObject); +begin + MyLArray.Get(LB1.ItemIndex,ARec); + ElemNum.Text := IntToStr(LB1.ItemIndex); + FillControls; +end; + +procedure TSTDlg.LoadBtnClick(Sender: TObject); +begin + if (OD1.Execute) then + begin + if (NOT Assigned(MyLArray)) then + begin + UpdateButtons(False); + MyLArray := TStLArray.Create(5000, sizeof(ARec)); + MyLArray.ElementsStorable := True; + end; + + MyLArray.Clear; + MyLArray.LoadFromFile(OD1.FileName); + + FillListBox; + FillControls; + UpdateButtons(True); + end; +end; + +procedure TSTDlg.SaveBtnClick(Sender: TObject); +begin + if (SD1.Execute) then + MyLArray.StoreToFile(SD1.FileName); +end; + + +end. diff --git a/components/systools/examples/2d array/es2darr.lpi b/components/systools/examples/2d array/es2darr.lpi new file mode 100644 index 000000000..e0b3886d0 --- /dev/null +++ b/components/systools/examples/2d array/es2darr.lpi @@ -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> diff --git a/components/systools/examples/2d array/es2darr.lpr b/components/systools/examples/2d array/es2darr.lpr new file mode 100644 index 000000000..9dbe6ac0b --- /dev/null +++ b/components/systools/examples/2d array/es2darr.lpr @@ -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. diff --git a/components/systools/examples/2d array/ex2darru.lfm b/components/systools/examples/2d array/ex2darru.lfm new file mode 100644 index 000000000..0a662792e --- /dev/null +++ b/components/systools/examples/2d array/ex2darru.lfm @@ -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 diff --git a/components/systools/examples/2d array/ex2darru.pas b/components/systools/examples/2d array/ex2darru.pas new file mode 100644 index 000000000..eebc4a8d9 --- /dev/null +++ b/components/systools/examples/2d array/ex2darru.pas @@ -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. diff --git a/components/systools/examples/bcd_calculator/bcdcalc.lpi b/components/systools/examples/bcd_calculator/bcdcalc.lpi new file mode 100644 index 000000000..04a0356ba --- /dev/null +++ b/components/systools/examples/bcd_calculator/bcdcalc.lpi @@ -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="bcdcalc"/> + <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="bcdcalc.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="Bcdcalc"/> + </Unit0> + <Unit1> + <Filename Value="bcdcalu.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="BCDCalcDlg"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="BcdCalU"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="bcdcalc"/> + </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> diff --git a/components/systools/examples/bcd_calculator/bcdcalc.lpr b/components/systools/examples/bcd_calculator/bcdcalc.lpr new file mode 100644 index 000000000..5d3ed69aa --- /dev/null +++ b/components/systools/examples/bcd_calculator/bcdcalc.lpr @@ -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 Bcdcalc; + +uses + Interfaces, + Forms, lclversion, + bcdcalu in 'bcdcalu.pas' {BCDCalcDlg}; + +{$R *.res} + +begin + {$IF LCL_FULLVERSION >= 1080000} + Application.Scaled := True; + {$ENDIF} + Application.Initialize; + Application.CreateForm(TBCDCalcDlg, BCDCalcDlg); + Application.Run; +end. diff --git a/components/systools/examples/bcd_calculator/bcdcalu.lfm b/components/systools/examples/bcd_calculator/bcdcalu.lfm new file mode 100644 index 000000000..0f8d6ca20 --- /dev/null +++ b/components/systools/examples/bcd_calculator/bcdcalu.lfm @@ -0,0 +1,358 @@ +object BCDCalcDlg: TBCDCalcDlg + Left = 562 + Height = 275 + Top = 136 + Width = 260 + BorderIcons = [biSystemMenu] + BorderStyle = bsDialog + Caption = 'BCD Calculator' + ClientHeight = 275 + ClientWidth = 260 + Color = clBtnFace + Font.Color = clBlack + KeyPreview = True + OnCreate = FormCreate + OnKeyPress = FormKeyPress + Position = poScreenCenter + LCLVersion = '1.9.0.0' + object Bevel1: TBevel + Left = -4 + Height = 1 + Top = 0 + Width = 301 + end + object ZeroBtn: TBitBtn + Left = 56 + Height = 28 + Top = 238 + Width = 35 + Caption = '0' + Font.Color = clBlue + OnClick = ZeroBtnClick + ParentFont = False + TabOrder = 0 + TabStop = False + end + object DecKey: TBitBtn + Left = 136 + Height = 28 + Top = 238 + Width = 35 + Caption = '.' + Font.Color = clBlue + OnClick = DecKeyClick + ParentFont = False + TabOrder = 1 + TabStop = False + end + object ThreeKey: TBitBtn + Left = 136 + Height = 28 + Top = 205 + Width = 35 + Caption = '3' + Font.Color = clBlue + OnClick = ThreeKeyClick + ParentFont = False + TabOrder = 2 + TabStop = False + end + object OneKey: TBitBtn + Left = 56 + Height = 28 + Top = 205 + Width = 35 + Caption = '1' + Font.Color = clBlue + OnClick = OneKeyClick + ParentFont = False + TabOrder = 3 + TabStop = False + end + object TwoKey: TBitBtn + Left = 96 + Height = 28 + Top = 205 + Width = 35 + Caption = '2' + Font.Color = clBlue + OnClick = TwoKeyClick + ParentFont = False + TabOrder = 4 + TabStop = False + end + object SixKey: TBitBtn + Left = 136 + Height = 28 + Top = 173 + Width = 35 + Caption = '6' + Font.Color = clBlue + OnClick = SixKeyClick + ParentFont = False + TabOrder = 5 + TabStop = False + end + object FourKey: TBitBtn + Left = 56 + Height = 28 + Top = 173 + Width = 35 + Caption = '4' + Font.Color = clBlue + OnClick = FourKeyClick + ParentFont = False + TabOrder = 6 + TabStop = False + end + object FiveKey: TBitBtn + Left = 96 + Height = 28 + Top = 173 + Width = 35 + Caption = '5' + Font.Color = clBlue + OnClick = FiveKeyClick + ParentFont = False + TabOrder = 7 + TabStop = False + end + object NineKey: TBitBtn + Left = 136 + Height = 28 + Top = 140 + Width = 35 + Caption = '9' + Font.Color = clBlue + OnClick = NineKeyClick + ParentFont = False + TabOrder = 8 + TabStop = False + end + object SevenKey: TBitBtn + Left = 56 + Height = 28 + Top = 140 + Width = 35 + Caption = '7' + Font.Color = clBlue + OnClick = SevenKeyClick + ParentFont = False + TabOrder = 9 + TabStop = False + end + object EightKey: TBitBtn + Left = 96 + Height = 28 + Top = 140 + Width = 35 + Caption = '8' + Font.Color = clBlue + OnClick = EightKeyClick + ParentFont = False + TabOrder = 10 + TabStop = False + end + object SqrtBtn: TBitBtn + Left = 6 + Height = 28 + Top = 140 + Width = 35 + Caption = 'Sqrt' + Font.Color = clFuchsia + OnClick = SqrtBtnClick + ParentFont = False + TabOrder = 11 + TabStop = False + end + object LnBtn: TBitBtn + Left = 6 + Height = 28 + Top = 205 + Width = 35 + Caption = 'ln' + Font.Color = clFuchsia + OnClick = LnBtnClick + ParentFont = False + TabOrder = 12 + TabStop = False + end + object ExpBtn: TBitBtn + Left = 6 + Height = 28 + Top = 173 + Width = 35 + Caption = 'Exp' + Font.Color = clFuchsia + OnClick = ExpBtnClick + ParentFont = False + TabOrder = 13 + TabStop = False + end + object XtoYBtn: TBitBtn + Left = 6 + Height = 28 + Top = 238 + Width = 35 + Caption = 'x^y' + Font.Color = clFuchsia + OnClick = XtoYBtnClick + ParentFont = False + TabOrder = 14 + TabStop = False + end + object AddBtn: TBitBtn + Left = 174 + Height = 28 + Top = 140 + Width = 35 + Caption = '+' + Font.Color = clRed + OnClick = AddBtnClick + ParentFont = False + TabOrder = 15 + TabStop = False + end + object SubBtn: TBitBtn + Left = 174 + Height = 28 + Top = 173 + Width = 35 + Caption = '-' + Font.Color = clRed + OnClick = SubBtnClick + ParentFont = False + TabOrder = 16 + TabStop = False + end + object MulBtn: TBitBtn + Left = 174 + Height = 28 + Top = 205 + Width = 35 + Caption = '*' + Font.Color = clRed + OnClick = MulBtnClick + ParentFont = False + TabOrder = 17 + TabStop = False + end + object DivBtn: TBitBtn + Left = 174 + Height = 28 + Top = 238 + Width = 35 + Caption = '/' + Font.Color = clRed + OnClick = DivBtnClick + ParentFont = False + TabOrder = 18 + TabStop = False + end + object PlusMinusBtn: TBitBtn + Left = 96 + Height = 28 + Top = 238 + Width = 35 + Caption = '+/-' + Font.Color = clBlue + OnClick = PlusMinusBtnClick + ParentFont = False + TabOrder = 19 + TabStop = False + end + object ClearBtn: TBitBtn + Left = 192 + Height = 28 + Top = 106 + Width = 62 + Caption = 'C' + Font.Color = clRed + OnClick = ClearBtnClick + ParentFont = False + TabOrder = 20 + TabStop = False + end + object EqualBtn: TBitBtn + Left = 216 + Height = 126 + Top = 140 + Width = 37 + Caption = '=' + Font.Color = clRed + OnClick = EqualBtnClick + ParentFont = False + TabOrder = 21 + end + object ClearEntryBtn: TBitBtn + Left = 136 + Height = 28 + Top = 106 + Width = 50 + Caption = 'CE' + Font.Color = clRed + OnClick = ClearEntryBtnClick + ParentFont = False + TabOrder = 22 + TabStop = False + end + object gb1: TGroupBox + Left = 6 + Height = 51 + Top = 8 + Width = 248 + Caption = 'BCD Value' + ClientHeight = 31 + ClientWidth = 244 + TabOrder = 23 + object BCDString: TEdit + Left = 31 + Height = 23 + Top = 0 + Width = 187 + Color = clBtnFace + Enabled = False + ReadOnly = True + TabStop = False + TabOrder = 0 + end + end + object BSBtn: TBitBtn + Left = 56 + Height = 28 + Top = 106 + Width = 75 + Caption = 'Backspace' + Font.Color = clRed + OnClick = BSBtnClick + ParentFont = False + TabOrder = 24 + TabStop = False + end + object Memo1: TMemo + Left = 27 + Height = 25 + Top = 64 + Width = 205 + Alignment = taRightJustify + MaxLength = 40 + PopupMenu = PopupMenu1 + ReadOnly = True + TabOrder = 25 + WantReturns = False + WantTabs = True + WordWrap = False + end + object PopupMenu1: TPopupMenu + left = 112 + top = 32 + object Copy1: TMenuItem + Caption = 'Copy' + OnClick = Copy1Click + end + object Paste1: TMenuItem + Caption = 'Paste' + OnClick = Paste1Click + end + end +end diff --git a/components/systools/examples/bcd_calculator/bcdcalu.pas b/components/systools/examples/bcd_calculator/bcdcalu.pas new file mode 100644 index 000000000..1a2975ca4 --- /dev/null +++ b/components/systools/examples/bcd_calculator/bcdcalu.pas @@ -0,0 +1,534 @@ +(* ***** 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 ***** *) + +unit BcdCalU; + +interface + +uses + SysUtils, Windows, Classes, Graphics, Controls, + Forms, Dialogs, StdCtrls, ExtCtrls, Buttons, Menus, Clipbrd; + +type + BCDCharSet = set of Char; + BCDOperSet = set of Char; + +type + TBCDCalcDlg = class(TForm) + ZeroBtn: TBitBtn; + DecKey: TBitBtn; + ThreeKey: TBitBtn; + OneKey: TBitBtn; + TwoKey: TBitBtn; + SixKey: TBitBtn; + FourKey: TBitBtn; + FiveKey: TBitBtn; + NineKey: TBitBtn; + SevenKey: TBitBtn; + EightKey: TBitBtn; + SqrtBtn: TBitBtn; + LnBtn: TBitBtn; + ExpBtn: TBitBtn; + XtoYBtn: TBitBtn; + AddBtn: TBitBtn; + SubBtn: TBitBtn; + MulBtn: TBitBtn; + DivBtn: TBitBtn; + PlusMinusBtn: TBitBtn; + ClearBtn: TBitBtn; + EqualBtn: TBitBtn; + ClearEntryBtn: TBitBtn; + Bevel1: TBevel; + gb1: TGroupBox; + BCDString: TEdit; + BSBtn: TBitBtn; + Memo1: TMemo; + PopupMenu1: TPopupMenu; + Copy1: TMenuItem; + Paste1: TMenuItem; + procedure FormCreate(Sender: TObject); + procedure FormKeyPress(Sender: TObject; var Key: Char); + procedure CloseBtnClick(Sender: TObject); + procedure ClearBtnClick(Sender: TObject); + procedure ZeroBtnClick(Sender: TObject); + procedure DecKeyClick(Sender: TObject); + procedure OneKeyClick(Sender: TObject); + procedure TwoKeyClick(Sender: TObject); + procedure ThreeKeyClick(Sender: TObject); + procedure FourKeyClick(Sender: TObject); + procedure FiveKeyClick(Sender: TObject); + procedure SixKeyClick(Sender: TObject); + procedure SevenKeyClick(Sender: TObject); + procedure EightKeyClick(Sender: TObject); + procedure NineKeyClick(Sender: TObject); + procedure PlusMinusBtnClick(Sender: TObject); + procedure AddBtnClick(Sender: TObject); + procedure SubBtnClick(Sender: TObject); + procedure MulBtnClick(Sender: TObject); + procedure DivBtnClick(Sender: TObject); + procedure SqrtBtnClick(Sender: TObject); + procedure ExpBtnClick(Sender: TObject); + procedure LnBtnClick(Sender: TObject); + procedure XtoYBtnClick(Sender: TObject); + procedure EqualBtnClick(Sender: TObject); + procedure ClearEntryBtnClick(Sender: TObject); + procedure BSBtnClick(Sender: TObject); + procedure Copy1Click(Sender: TObject); + procedure Paste1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + BCDChar : BCDCharSet; + BCDOper : BCDOperSet; + PendOp : Char; + DFHold : Integer; + XBuffer : string[20]; + ClearOnNext : Boolean; + + procedure SendKeyPress(Sender : TObject; C : Char); + end; + + +var + BCDCalcDlg: TBCDCalcDlg; + +implementation + +{$R *.lfm} + +uses + StConst, + StBase, + StStrL, + StBCD; + +procedure TBCDCalcDlg.FormCreate(Sender: TObject); +begin + BCDChar := ['0'..'9', SysUtils.DecimalSeparator, 'p']; + BCDOper := ['+', '-', '/', '*', '^', 'e', 'l', 's', '=']; + DecKey.Caption := FormatSettings.DecimalSeparator; + Memo1.Lines.Text := '0'; + PendOp := #0; + DFHold := 0; + XBuffer := '0'; + ClearOnNext := False; +end; + + +function BytesToString(Value : PByte; Size : Cardinal) : string; + {-convert byte array to string, no spaces or hex enunciators, e.g., '$'} +var + I, + Index : Cardinal; + S : String[3]; +begin + {$IFOPT H+} + SetLength(Result,2*Size); + {$ELSE} + Result[0] := AnsiChar(Size*2); + {$ENDIF} + + for I := 1 to Size do + begin + Index := I*2; + {$IFOPT H+} + S := HexBL(Byte(PAnsiChar(Value)[I-1])); + {$ELSE} + S := HexBS(Byte(PAnsiChar(Value)[I-1]); + {$ENDIF} + Result[(Index)-1] := S[1]; + Result[Index] := S[2]; + end; +end; + +function StringToBytes(IString : string; var Value; Size : LongInt) : Boolean; + {-convert string (by groups of 2 char) to byte values} +var + Code, + Index, + I : Integer; + Q : TBcd; + S : array[1..3] of AnsiChar; +begin + if ((Length(IString) div 2) <> Size) then + begin + Result := False; + Exit; + end; + + Result := True; + for I := 1 to Size do + begin + Index := (2*(I-1))+1; + S[1] := '$'; + S[2] := IString[Index]; + S[3] := IString[Index+1]; + Val(S,Q[I-1],Code); + if (Code <> 0) then + begin + Result := False; + Exit; + end; + end; + Move(Q,Value,Size); +end; + +procedure TBCDCalcDlg.FormKeyPress(Sender: TObject; var Key: Char); +var + HldOp : Char; + L : Integer; + BCD1 : TBcd; + S : string[21]; +begin + if Memo1.Lines[0] = '0' then + Memo1.Lines[0] := ''; + + if Key = #13 then begin + if XBuffer = '0' then + XBuffer := Memo1.Lines[0] + else begin + EqualBtnClick(Sender); + XBuffer := '0'; + end; + Key := #0; + ClearOnNext := True; + end; + + if Key in BCDChar then begin + if (Length(Memo1.Lines[0]) = 0) and (Key = SysUtils.DecimalSeparator) then begin + Memo1.Lines[0] := '0'; + end; + if (Key = 'p') then begin + S := Memo1.Lines[0]; + if (S[1] <> '-') then + Insert('-',S,1) + else + Delete(S,1,1); + Memo1.Lines[0] := S; + BCD1 := ValBcd(S); + BCDString.Text := BytesToString(@BCD1,SizeOf(BCD1)); + Key := #0; + end else begin + if ClearOnNext then begin + Memo1.Lines[0] := ''; + ClearOnNext := False; + end; + end; + end; + + if Key in BCDOper then begin + if not (Key in ['s', 'e', 'l']) then begin + if Memo1.Lines[0] = '' then + Memo1.Lines[0] := '0'; + if (XBuffer <> '0') then + EqualBtnClick(Sender); + XBuffer := Memo1.Lines[0]; + BCD1 := ValBcd(XBuffer); + BCDString.Text := BytesToString(@BCD1,SizeOf(BCD1)); + PendOp := Key; + Key := #0; + ClearOnNext := True; + end else begin + HldOp := PendOp; + PendOp := Key; + EqualBtnClick(Sender); + PendOp := HldOp; + Key := #0; + end; + end; + + if (Key in BCDChar) then begin + S := Memo1.Lines[0]; + L := Length(S); + if (L < Memo1.MaxLength) then begin + Memo1.Lines[0] := S + Key; + end; + Key := #0 + end; + Memo1.SetFocus; + Memo1.SelStart := Length(Memo1.Lines[0]); + Memo1.SelLength := 0; +end; + + +procedure TBCDCalcDlg.CloseBtnClick(Sender: TObject); +begin + Close; +end; + +procedure TBCDCalcDlg.ClearBtnClick(Sender: TObject); +begin + XBuffer := '0'; + Memo1.Lines[0] := '0'; + BCDString.Text := ''; + PendOp := #0; + ClearOnNext := True; +end; + +procedure TBCDCalcDlg.ClearEntryBtnClick(Sender: TObject); +begin + Memo1.Lines[0] := '0'; + ClearOnNext := True; +end; + +procedure TBCDCalcDlg.SendKeyPress(Sender : TObject; C : Char); +var + KP : Char; +begin + KP := C; + FormKeyPress(Sender,KP); +end; + +procedure TBCDCalcDlg.ZeroBtnClick(Sender: TObject); +begin + SendKeyPress(Sender,'0'); +end; + +procedure TBCDCalcDlg.DecKeyClick(Sender: TObject); +begin + SendKeyPress(Sender, SysUtils.DecimalSeparator); +end; + +procedure TBCDCalcDlg.OneKeyClick(Sender: TObject); +begin + SendKeyPress(Sender,'1'); +end; + +procedure TBCDCalcDlg.TwoKeyClick(Sender: TObject); +begin + SendKeyPress(Sender,'2'); +end; + +procedure TBCDCalcDlg.ThreeKeyClick(Sender: TObject); +begin + SendKeyPress(Sender,'3'); +end; + +procedure TBCDCalcDlg.FourKeyClick(Sender: TObject); +begin + SendKeyPress(Sender,'4'); +end; + +procedure TBCDCalcDlg.FiveKeyClick(Sender: TObject); +begin + SendKeyPress(Sender,'5'); +end; + +procedure TBCDCalcDlg.SixKeyClick(Sender: TObject); +begin + SendKeyPress(Sender,'6'); +end; + +procedure TBCDCalcDlg.SevenKeyClick(Sender: TObject); +begin + SendKeyPress(Sender,'7'); +end; + +procedure TBCDCalcDlg.EightKeyClick(Sender: TObject); +begin + SendKeyPress(Sender,'8'); +end; + +procedure TBCDCalcDlg.NineKeyClick(Sender: TObject); +begin + SendKeyPress(Sender,'9'); +end; + +procedure TBCDCalcDlg.PlusMinusBtnClick(Sender: TObject); +begin + SendKeyPress(Sender,'p'); +end; + +procedure TBCDCalcDlg.AddBtnClick(Sender: TObject); +begin + SendKeyPress(Sender,'+'); +end; + +procedure TBCDCalcDlg.SubBtnClick(Sender: TObject); +begin + SendKeyPress(Sender,'-'); +end; + +procedure TBCDCalcDlg.MulBtnClick(Sender: TObject); +begin + SendKeyPress(Sender,'*'); +end; + +procedure TBCDCalcDlg.DivBtnClick(Sender: TObject); +begin + SendKeyPress(Sender,'/'); +end; + +procedure TBCDCalcDlg.SqrtBtnClick(Sender: TObject); +begin + SendKeyPress(Sender,'s'); +end; + +procedure TBCDCalcDlg.ExpBtnClick(Sender: TObject); +begin + SendKeyPress(Sender,'e'); +end; + +procedure TBCDCalcDlg.LnBtnClick(Sender: TObject); +begin + SendKeyPress(Sender,'l'); +end; + +procedure TBCDCalcDlg.XtoYBtnClick(Sender: TObject); +begin + SendKeyPress(Sender,'^'); +end; + +procedure TBCDCalcDlg.EqualBtnClick(Sender: TObject); +var +// RV : Extended; + S : string[21]; + BCD : TBcd; +begin + if PendOp <> #0 then begin + S := Memo1.Lines[0]; + if S = '' then begin + MessageBeep(0); + Exit; + end; + case PendOp of + '+' : begin +// RV := StrToFloat(XBuffer) + StrToFloat(S); + BCD := AddBCD(ValBCD(XBuffer), ValBCD(S)); +// Memo1.Lines[0] := FloatToStr(RV); + Memo1.Lines[0] := RightTrimCharsL(Trim(StrBCD(BCD, 35, 20)), '0'); +// BCD := ValBcd(Memo1.Lines[0]); + BCDString.Text := BytesToString(@BCD,SizeOf(BCD)); + end; + '-' : begin +// RV := StrToFloat(XBuffer) - StrToFloat(S); + BCD := SubBCD(ValBCD(XBuffer), ValBCD(S)); +// Memo1.Lines[0] := FloatToStr(RV); + Memo1.Lines[0] := RightTrimCharsL(Trim(StrBCD(BCD, 35, 20)), '0'); +// BCD := ValBcd(Memo1.Lines[0]); + BCDString.Text := BytesToString(@BCD,SizeOf(BCD)); + end; + '*' : begin +// RV := StrToFloat(XBuffer) * StrToFloat(S); + BCD := MulBCD(ValBCD(XBuffer), ValBCD(S)); +// Memo1.Lines[0] := FloatToStr(RV); + Memo1.Lines[0] := RightTrimCharsL(Trim(StrBCD(BCD, 35, 20)), '0'); +// BCD := ValBcd(Memo1.Lines[0]); + BCDString.Text := BytesToString(@BCD,SizeOf(BCD)); + end; + '/' : begin +// RV := StrToFloat(S); + BCD := ValBCD(S); +// if RV = 0 then begin + if CmpBcd(BCD, ZeroBcd) = 0 then begin + Memo1.Lines[0] := 'Divide by zero error'; + PendOp := #0; + ClearOnNext := False; + end else begin +// RV := StrToFloat(XBuffer) / StrToFloat(S); + BCD := DivBCD(ValBCD(XBuffer), BCD); +// Memo1.Lines[0] := FloatToStr(RV); + Memo1.Lines[0] := RightTrimCharsL(Trim(StrBCD(BCD, 35, 20)), '0'); +// BCD := ValBcd(Memo1.Lines[0]); + BCDString.Text := BytesToString(@BCD,SizeOf(BCD)); + end; + end; + 's' : begin +// RV := Sqrt(StrToFloat(S)); + BCD := SqrtBcd(ValBCD(S)); +// Memo1.Lines[0] := FloatToStr(RV); + Memo1.Lines[0] := RightTrimCharsL(Trim(StrBCD(BCD, 35, 20)), '0'); +// BCD := ValBcd(Memo1.Lines[0]); + BCDString.Text := BytesToString(@BCD,SizeOf(BCD)); + end; + 'e' : begin +// RV := Exp(StrToFloat(S)); + BCD := ExpBCD(ValBCD(S)); +// Memo1.Lines[0] := FloatToStr(RV); + Memo1.Lines[0] := RightTrimCharsL(Trim(StrBCD(BCD, 35, 20)), '0'); +// BCD := ValBcd(Memo1.Lines[0]); + BCDString.Text := BytesToString(@BCD,SizeOf(BCD)); + end; + 'l' : begin +// RV := ln(StrToFloat(S)); + BCD := lnBCD(ValBCD(S)); +// Memo1.Lines[0] := FloatToStr(RV); + Memo1.Lines[0] := RightTrimCharsL(Trim(StrBCD(BCD, 35, 20)), '0'); +// BCD := ValBcd(Memo1.Lines[0]); + BCDString.Text := BytesToString(@BCD,SizeOf(BCD)); + end; + '^' : begin +// RV := exp(ln(StrToFloat(XBuffer)) * StrToFloat(S)); + BCD := PowBCD(ValBCD(XBuffer), ValBCD(S)); +// Memo1.Lines[0] := FloatToStr(RV); + Memo1.Lines[0] := RightTrimCharsL(Trim(StrBCD(BCD, 35, 20)), '0'); +// BCD := ValBcd(Memo1.Lines[0]); + BCDString.Text := BytesToString(@BCD,SizeOf(BCD)); + end; + + end; + end; + PendOp := #0; + ClearOnNext := True; + Memo1.SetFocus; + Memo1.SelStart := 0; + Memo1.SelLength := 0; +end; + + +procedure TBCDCalcDlg.BSBtnClick(Sender: TObject); +begin + Memo1.Lines[0] := Copy(Memo1.Lines[0], 1, Length(Memo1.Lines[0]) - 1); + if Length(Memo1.Lines[0]) = 0 then + ClearBtnClick(ClearBtn); +end; + +procedure TBCDCalcDlg.Copy1Click(Sender: TObject); +begin + Memo1.SelectAll; + Memo1.CopyToClipboard; + Memo1.SelStart := 0; +end; + +procedure TBCDCalcDlg.Paste1Click(Sender: TObject); +var + S : string; + IsNeg : Boolean; +begin + S := Clipboard.AsText; + IsNeg := False; + if (S[1] = '-') then begin + IsNeg := True; + S := Copy(S, 2, Length(S) - 1); + end; + + if IsStrNumericL(S, '0123456789' + SysUtils.DecimalSeparator) then begin + if IsNeg then S := '-' + S; + Memo1.Lines[0] := S; + end; +end; + +end. diff --git a/components/systools/laz_systools.lpk b/components/systools/laz_systools.lpk index 435012ff9..c963029e9 100644 --- a/components/systools/laz_systools.lpk +++ b/components/systools/laz_systools.lpk @@ -16,7 +16,7 @@ <Description Value="Lazarus port of TurboPower SysTools (Delphi version at https://sourceforge.net/projects/tpsystools/) - runtime package"/> <License Value="MPL 1.1"/> <Version Major="4" Release="4"/> - <Files Count="23"> + <Files Count="25"> <Item1> <Filename Value="source\run\stbarc.pas"/> <UnitName Value="StBarC"/> @@ -109,6 +109,14 @@ <Filename Value="source\run\ststat.pas"/> <UnitName Value="StStat"/> </Item23> + <Item24> + <Filename Value="source\run\stlarr.pas"/> + <UnitName Value="StLArr"/> + </Item24> + <Item25> + <Filename Value="source\run\stbcd.pas"/> + <UnitName Value="StBCD"/> + </Item25> </Files> <RequiredPkgs Count="2"> <Item1> diff --git a/components/systools/laz_systools.pas b/components/systools/laz_systools.pas index e0f03b538..40579f4fc 100644 --- a/components/systools/laz_systools.pas +++ b/components/systools/laz_systools.pas @@ -10,7 +10,7 @@ interface uses StBarC, StBase, StConst, StBarPN, StStrL, St2DBarC, StDate, StUtils, StCRC, StHASH, StToHTML, StStrms, StDict, StIniStm, StDecMth, StExpr, StMath, - StFIN, StDateSt, StMoney, StRandom, StStat; + StFIN, StDateSt, StMoney, StRandom, StStat, StLArr, StBCD; implementation diff --git a/components/systools/source/design/StReg.pas b/components/systools/source/design/StReg.pas index 572503752..bd4b6b4ae 100644 --- a/components/systools/source/design/StReg.pas +++ b/components/systools/source/design/StReg.pas @@ -88,7 +88,9 @@ uses {vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv} StAstro, StAstroP, + *) StBCD, + (* StBits, StColl, *) diff --git a/components/systools/source/run/StBase.pas b/components/systools/source/run/stbase.pas similarity index 100% rename from components/systools/source/run/StBase.pas rename to components/systools/source/run/stbase.pas diff --git a/components/systools/source/run/stbcd.pas b/components/systools/source/run/stbcd.pas new file mode 100644 index 000000000..7962ecb5c --- /dev/null +++ b/components/systools/source/run/stbcd.pas @@ -0,0 +1,2906 @@ +// 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: StBCD.pas 4.04 *} +{*********************************************************} +{* SysTools: BCD arithmetic functions *} +{*********************************************************} + +{$IFDEF FPC} + {$mode DELPHI} +{$ENDIF} + +//{$I StDefine.inc} + +{Notes: + The BCD format matches that defined by Turbo Pascal 3.0. It is as follows: + + LSB MSB (most significant byte at end) + |<------ Mantissa ------>| + 1 2 3 4 5 6 7 8 9 10 <- Byte # + sE ML ML ML ML ML ML ML ML ML + ^ ^^--- Less significant digit + | |---- More significant digit + | + v + 7 6 5 4 3 2 1 0 <-- Bit # (in Byte 1) + s E E E E E E E + ^ <--exponent-> + | | + | |--- exponent has offset of $3F (eg, $41 means 10^2 = 100) + |----------- sign bit (0 = positive, 1 = negative) + + Unpacked BCD format + ------------------- + Many of the routines that follow work with these reals in an unpacked + format. That is, before an arithmetic operation is performed, the mantissas + are expanded (unpacked) so that there is one digit per byte. After unpacking, + the reals look like this: + + LSB MSB + |<------------------ mantissa --------------------->| + 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + sE 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 00 + ^^ + ||---- Digit + |----- 0 + Byte 1 is unchanged. + Bytes 2-19 contain the digits in the mantissa, LSB first. The high + nibble of each byte is 0, and the low nibble contains the digit. + Byte 20, sometimes used to keep track of overflow, is set to 0. + + The constant BcdSize determines the size and accuracy of the Bcd + routines. It can be any value in the range 4-20 bytes. The default + value of 10 gives 18 digits of accuracy. A size of 20 gives 38 digits + of accuracy. + + The BCD routines are thread-aware; all temporary variables are local. + + STBCD uses the DecimalSeparator global variable from the SYSUTILS unit + wherever it needs a decimal point. As such the formatting of BCD + strings is aware of international differences. + + The transcendental routines (Sqrt, Ln, Exp, Pow) are accurate for + all but 1 or 2 of the available digits of storage. For BcdSize = + 10, this means 16-17 accurate digits; for BcdSize = 20, this means + 36-37 accurate digits. The last digit or two is lost to roundoff + errors during the calculations. + + Algorithms used for transcendental routines (depending on BcdSize): + Sqrt: + Herron's iterative approximation + Exp: + <= 10 bytes, Chebyshev polynomials per Cody and Waite + > 10 bytes, traditional series expansion + Ln: + <= 10 bytes, Chebyshev polynomials of rational approximation + per Cody and Waite + > 10 bytes, Carlson's iterative approximation + Pow: + straight multiplication for integer powers + use of Exp and Ln for non-integer powers + + Computation of Exp and Ln for BcdSize > 10 bytes is quite slow. Exp + takes up to 30 terms to fill in all the digits when BcdSize = 20. + Ln takes 9 iterations for BcdSize = 20, but each iteration is complicated + and involves a sqrt, a divide, and other simpler operations. + + FormatBcd mimics the FormatFloat routine from the SYSUTILS unit. + StrGeneralBcd mimics the FloatToStrF routine with the ffGeneral option. + See the documentation for those routines for more information. +} + + +unit StBCD; + +interface + +uses + {$IFNDEF FPC} + Windows, + {$ENDIF} + SysUtils, + StConst, + StBase, + StStrL; + +const + BcdSize = 10; {bytes in BCD, valid range 4-20} + {.Z+} + MantissaDigits = 2*(BcdSize-1); {digits in mantissa} + OverflowChar = '*'; {character used to fill an overflow string} + {.Z-} + +type + TBcd = array[0..BcdSize-1] of Byte; + +var + {these values are set up by the initialization block} + ZeroBcd : TBcd; + MinBcd : TBcd; + MaxBcd : TBcd; + BadBcd : TBcd; + PiBcd : TBcd; + eBcd : TBcd; + Ln10Bcd : TBcd; + +{$IFNDEF CBuilder} +function AddBcd(const B1, B2 : TBcd) : TBcd; + {-Return B1+B2} +function SubBcd(const B1, B2 : TBcd) : TBcd; + {-Return B1-B2} +function MulBcd(const B1, B2 : TBcd) : TBcd; + {-Return B1*B2} +function DivBcd(const B1, B2 : TBcd) : TBcd; + {-Return B1/B2} +function ModBcd(const B1, B2 : TBcd) : TBcd; + {-Return B1 mod B2} +function NegBcd(const B : TBcd) : TBcd; + {-Return the negative of B} +function AbsBcd(const B : TBcd) : TBcd; + {-Return the absolute value of B} +function FracBcd(const B : TBcd) : TBcd; + {-Return the fractional part of B} +function IntBcd(const B : TBcd) : TBcd; + {-Return the integer part of B, as a BCD real} +function RoundDigitsBcd(const B : TBcd; Digits : Cardinal) : TBcd; + {-Return B rounded to specified total digits of accuracy} +function RoundPlacesBcd(const B : TBcd; Places : Cardinal) : TBcd; + {-Return B rounded to specified decimal places of accuracy} +function ValBcd(const S : string) : TBcd; + {-Convert a string to a BCD} +function LongBcd(L : LongInt) : TBcd; + {-Convert a long integer to a BCD} +function ExtBcd(E : Extended) : TBcd; + {-Convert an extended real to a BCD} +function ExpBcd(const B : TBcd) : TBcd; + {-Return e**B} +function LnBcd(const B : TBcd) : TBcd; + {-Return natural log of B} +function IntPowBcd(const B : TBcd; E : LongInt) : TBcd; + {-Return B**E, where E is an integer} +function PowBcd(const B, E : TBcd) : TBcd; + {-Return B**E} +function SqrtBcd(const B : TBcd) : TBcd; + {-Return the square root of B} +{$ENDIF} + +function CmpBcd(const B1, B2 : TBcd) : Integer; + {-Return <0 if B1<B2, =0 if B1=B2, >0 if B1>B2} +function EqDigitsBcd(const B1, B2 : TBcd; Digits : Cardinal) : Boolean; + {-Return True if B1 and B2 are equal after rounding to specified digits} +function EqPlacesBcd(const B1, B2 : TBcd; Digits : Cardinal) : Boolean; + {-Return True if B1 and B2 are equal after rounding to specified decimal places} +function IsIntBcd(const B : TBcd) : Boolean; + {-Return True if B has no fractional part (may still not fit into a LongInt)} +function TruncBcd(const B : TBcd) : LongInt; + {-Return B after discarding its fractional part} +function BcdExt(const B : TBcd) : Extended; + {-Convert B to an extended real} +function RoundBcd(const B : TBcd) : LongInt; + {-Round B rounded to the nearest integer} +function StrBcd(const B : TBcd; Width, Places : Cardinal) : string; + {-Convert BCD to a string in floating point format} +function StrExpBcd(const B : TBcd; Width : Cardinal) : string; + {-Convert BCD to a string in scientific format} +function FormatBcd(const Format: string; const B : TBcd): string; + {-Format a BCD like FormatFloat does for Extended} +function StrGeneralBcd(const B : TBcd) : string; + {-Format a BCD like FloatToStrF does with ffGeneral format, MantissaDigits + for Precision, and zero for Digits} +function FloatFormBcd(const Mask : string; B : TBCD; + const LtCurr, RtCurr : string; + Sep, DecPt : Char) : string; + {-Returns a formatted string with digits from B merged into the Mask} +procedure ConvertBcd(const SrcB; SrcSize : Byte; var DestB; DestSize : Byte); + {-Convert a BCD of one size to another size} + +{the following routines are provided to support C++Builder} +{$IFDEF CBuilder} +procedure AddBcd_C(const B1, B2 : TBcd; var Res : TBcd); +procedure SubBcd_C(const B1, B2 : TBcd; var Res : TBcd); +procedure MulBcd_C(const B1, B2 : TBcd; var Res : TBcd); +procedure DivBcd_C(const B1, B2 : TBcd; var Res : TBcd); +procedure ModBcd_C(const B1, B2 : TBcd; var Res : TBcd); +procedure NegBcd_C(const B : TBcd; var Res : TBcd); +procedure AbsBcd_C(const B : TBcd; var Res : TBcd); +procedure FracBcd_C(const B : TBcd; var Res : TBcd); +procedure IntBcd_C(const B : TBcd; var Res : TBcd); +procedure RoundDigitsBcd_C(const B : TBcd; Digits : Cardinal; var Res : TBcd); +procedure RoundPlacesBcd_C(const B : TBcd; Places : Cardinal; var Res : TBcd); +procedure ValBcd_C(const S : string; var Res : TBcd); +procedure LongBcd_C(L : LongInt; var Res : TBcd); +procedure ExtBcd_C(E : Extended; var Res : TBcd); +procedure ExpBcd_C(const B : TBcd; var Res : TBcd); +procedure LnBcd_C(const B : TBcd; var Res : TBcd); +procedure IntPowBcd_C(const B : TBcd; E : LongInt; var Res : TBcd); +procedure PowBcd_C(const B, E : TBcd; var Res : TBcd); +procedure SqrtBcd_C(const B : TBcd; var Res : TBcd); +{$ENDIF} + +{the following function is interfaced to avoid hints from the compiler} +{for its non use when the BcdSize constant is set a value less than 11} +{$IFNDEF CBuilder} +function LnBcd20(const B : TBcd) : TBcd; +{$ENDIF} + +{=========================================================} + +implementation + +{Define to use assembly language in primitive routines below} +{$DEFINE UseAsm} + +const + NoSignBit = $7F; {mask to get just the exponent} + SignBit = $80; {mask to get just the sign} + ExpBias = $3F; {bias added to actual exponent value} + SigDigits = MantissaDigits+1; {counts overflow digit} + +type + TUnpBcd = array[0..SigDigits] of Byte; {unpacked BCD} + PUnpBcd = ^TUnpBcd; + TIntBcd = array[0..4*BcdSize-1] of Byte; {double size buffer for mult/div} + +{$IFDEF CBuilder} +function AddBcd(const B1, B2 : TBcd) : TBcd; forward; +function SubBcd(const B1, B2 : TBcd) : TBcd; forward; +function MulBcd(const B1, B2 : TBcd) : TBcd; forward; +function DivBcd(const B1, B2 : TBcd) : TBcd; forward; +function ModBcd(const B1, B2 : TBcd) : TBcd; forward; +function NegBcd(const B : TBcd) : TBcd; forward; +function AbsBcd(const B : TBcd) : TBcd; forward; +function FracBcd(const B : TBcd) : TBcd; forward; +function IntBcd(const B : TBcd) : TBcd; forward; +function RoundDigitsBcd(const B : TBcd; Digits : Cardinal) : TBcd; forward; +function RoundPlacesBcd(const B : TBcd; Places : Cardinal) : TBcd; forward; +function ValBcd(const S : string) : TBcd; forward; +function LongBcd(L : LongInt) : TBcd; forward; +function ExtBcd(E : Extended) : TBcd; forward; +function ExpBcd(const B : TBcd) : TBcd; forward; +function LnBcd(const B : TBcd) : TBcd; forward; +function IntPowBcd(const B : TBcd; E : LongInt) : TBcd; forward; +function PowBcd(const B, E : TBcd) : TBcd; forward; +function SqrtBcd(const B : TBcd) : TBcd; forward; +{$ENDIF} + +function FastValPrep(S : String) : String; +var + I : LongInt; +begin + I := Pos('.', S); + if I > 0 then + S[I] := {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator; + Result := S; +end; + +procedure RaiseBcdError(Code : LongInt); +var + E : EStBCDError; +begin + E := EStBCDError.CreateResTP(Code, 0); + E.ErrorCode := Code; + raise E; +end; + +procedure AddMantissas(const UB1 : TUnpBcd; var UB2 : TUnpBcd); +{$IFDEF UseAsm} + asm + push esi + push edi + mov esi,UB1 + mov edi,UB2 + {inc esi} + {inc edi} + mov ecx,SigDigits + clc +@1: mov al,[esi] {UB1} + inc esi + adc al,[edi] {UB1+UB2+CF} + aaa + mov [edi],al {update UB2} + inc edi + dec ecx + jnz @1 + jnc @2 + inc byte ptr [edi] +@2: pop edi + pop esi + end; +{$ELSE} +var + I : Integer; + T, C : Byte; +begin + C := 0; + for I := 0 to MantissaDigits do begin + T := UB2[I]+UB1[I]+C; + if T > 9 then begin + C := 1; + dec(T, 10); + end else + C := 0; + UB2[I] := T; + end; + UB2[SigDigits] := C; +end; +{$ENDIF} + +function IsZeroMantissa(const UB : TUnpBcd) : Boolean; +{$IFDEF UseAsm} + asm + push edi + mov edi,UB + {inc edi} + xor al,al + mov ecx,SigDigits + repe scasb + jne @1 + inc al +@1:pop edi + end; +{$ELSE} +var + I : Integer; +begin + for I := 0 to MantissaDigits do + if UB[I] <> 0 then begin + Result := False; + Exit; + end; + Result := True; +end; +{$ENDIF} + +procedure NegMantissa(var UB : TUnpBcd); +{$IFDEF UseAsm} + asm + push edi + mov edi,UB + {inc edi} + mov ecx,SigDigits + xor dh,dh + clc +@1: mov al,dh + sbb al,[edi] + aas + mov [edi],al + inc edi + dec ecx + jnz @1 + pop edi + end; +{$ELSE} +var + I : Integer; + C : Byte; +begin + C := 1; + for I := 0 to MantissaDigits do begin + UB[I] := 9+C-UB[I]; + if UB[I] > 9 then begin + dec(UB[I], 10); + C := 1; + end else + C := 0; + end; +end; +{$ENDIF} + +procedure NormalizeMantissa(var UB : TunpBcd; var E : Integer); +var + I, Shift : Integer; +begin + {find most significant non-zero digit} + for I := MantissaDigits downto 0 do + if UB[I] <> 0 then begin + Shift := MantissaDigits-I; + if Shift >= E then begin + {number disappears} + E := 0; + FillChar(UB[0], SigDigits, 0); + end else if Shift <> 0 then begin + dec(E, Shift); + move(UB[0], UB[Shift], SigDigits-Shift); + FillChar(UB[0], Shift, 0); + end; + Exit; + end; + {mantissa is all zeros} + E := 0; +end; + +procedure SetZero(var B : TBcd); +begin + FillChar(B, SizeOf(TBcd), 0); +end; + +procedure Pack(const UB : TUnpBcd; Exponent : Integer; Sign : Byte; + var B : TBcd); +{$IFNDEF UseAsm} +var + I : Integer; +{$ENDIF} +begin + if Exponent <= 0 then + SetZero(B) + + else begin + B[0] := Sign or Exponent; + {repack digits} +{$IFDEF UseAsm} + asm + push esi + push edi + mov esi,UB + mov edi,B + inc esi + inc edi + mov ecx,BcdSize-1 +@1: mov ax,[esi] + inc esi + inc esi + shl ah,4 + or al,ah + mov [edi],al + inc edi + dec ecx + jnz @1 + pop edi + pop esi + end; +{$ELSE} + for I := 1 to BcdSize-1 do + B[I] := UB[2*I-1] or (UB[2*I] shl 4); + {overflow digit ignored} +{$ENDIF} + end; +end; + +procedure RoundMantissa(var UB : TUnpBcd; Start : Integer); +var +{$IFNDEF UseAsm} + I : Integer; +{$ENDIF} + C : Byte; +begin + if Start > MantissaDigits then begin + Start := SigDigits; + C := 0; + end else + C := UB[Start]; + FillChar(UB[1], Start, 0); + if C < 5 then + Exit; +{$IFDEF UseAsm} + asm + push edi + mov edi,UB + mov eax,Start + add edi,eax + inc edi + mov ecx,MantissaDigits + sub ecx,eax + jle @2 + stc +@1: mov al,[edi] + adc al,0 + aaa + mov [edi],al + inc edi + jnc @3 + dec ecx + jnz @1 +@2: inc byte ptr [edi] +@3: pop edi + end; +{$ELSE} + C := 1; + for I := Start+1 to MantissaDigits do begin + inc(UB[I], C); + if UB[I] > 9 then begin + dec(UB[I], 10); + C := 1; + end else + {done rounding} + Exit; + end; + {set overflow digit if we get here} + inc(UB[SigDigits]); +{$ENDIF} +end; + +procedure ShiftMantissaDown(var UB : TUnpBcd; Shift : Integer); +begin + if Shift > MantissaDigits then + {UB disappears when shifted} + FillChar(UB[0], SigDigits+1, 0) + + else if Shift > 0 then begin + Move(UB[Shift], UB[0], SigDigits+1-Shift); + FillChar(UB[SigDigits+1-Shift], Shift, 0); + end; +end; + +procedure SubMantissas(const UB1 : TUnpBcd; var UB2 : TUnpBcd); +{$IFDEF UseAsm} + asm + push esi + push edi + mov esi,UB1 + mov edi,UB2 + {inc esi} + {inc edi} + mov ecx,SigDigits + clc +@1: mov al,[edi] {UB2} + sbb al,[esi] {UB2-UB1-CF} + aas + mov [edi],al {update UB2} + inc edi + inc esi + dec ecx + jnz @1 + jnc @2 + inc byte ptr [edi] +@2: pop edi + pop esi + end; +{$ELSE} +var + I : Integer; + T, C : ShortInt; +begin + C := 0; + for I := 0 to MantissaDigits do begin + T := UB2[I]-UB1[I]-C; + if T < 0 then begin + C := 1; + inc(T, 10); + end else + C := 0; + UB2[I] := T; + end; + UB2[SigDigits] := C; +end; +{$ENDIF} + +procedure Unpack(const B : TBcd; var UB : TUnpBcd; + var Exponent : Integer; var Sign : Byte); +{$IFNDEF UseAsm} +var + I : Integer; +{$ENDIF} +begin +{$IFDEF UseAsm} + asm + {$IFDEF VER140} + push ecx { get round a compiler bug in D6 } + {$ENDIF} + push esi + push edi + mov esi,B + mov edi,UB + inc esi + inc edi + mov ecx,BcdSize-1 +@1: mov al,[esi] + inc esi + mov ah,al + and al,$0F + shr ah,4 + mov [edi],ax + inc edi + inc edi + dec ecx + jnz @1 + xor al,al + mov [edi],al + pop edi + pop esi + {$IFDEF VER140} + pop ecx { get round a compiler bug in D6 } + {$ENDIF} + end; +{$ELSE} + {unpack digits} + for I := 1 to BcdSize-1 do begin + UB[2*I-1] := B[I] and $F; + UB[2*I] := B[I] shr 4; + end; + {set last overflow digit to zero} + UB[2*BcdSize-1] := 0; +{$ENDIF} + + {copy sign/exponent} + UB[0] := 0; + Exponent := B[0] and NoSignBit; + Sign := B[0] and SignBit; +end; + +{----------------------------------------------------------------------} + +function AbsBcd(const B : TBcd) : TBcd; +begin + Result := B; + Result[0] := B[0] and noSignBit; +end; + +function AddBcd(const B1, B2 : TBcd) : TBcd; +var + E1, E2 : Integer; + S1, S2 : Byte; + UB1, UB2 : TUnpBcd; +begin + if B1[0] = 0 then + Result := B2 + + else if B2[0] = 0 then + Result := B1 + + else begin + Unpack(B1, UB1, E1, S1); + Unpack(B2, UB2, E2, S2); + + If E1 < E2 then begin + {shift UB1's mantissa to account for smaller exponent} + RoundMantissa(UB1, E2-E1-1); + ShiftMantissaDown(UB1, E2-E1); + end else if E1 > E2 then begin + {shift UB2's mantissa to account for smaller exponent} + RoundMantissa(UB2, E1-E2-1); + ShiftMantissaDown(UB2, E1-E2); + E2 := E1; + end; + + if S1 <> S2 then begin + {differing signs} + SubMantissas(UB1, UB2); + if UB2[SigDigits] <> 0 then begin + {negative result} + S2 := S2 xor SignBit; + UB2[SigDigits] := 0; + NegMantissa(UB2); + end; + {shift to get rid of any leading zeros} + NormalizeMantissa(UB2, E2); + end else begin + {same signs} + AddMantissas(UB1, UB2); + if UB2[SigDigits] = 0 then + RoundMantissa(UB2, 0); + if UB2[SigDigits] <> 0 then begin + {temporary overflow} + RoundMantissa(UB2, 1); + ShiftMantissaDown(UB2, 1); + inc(E2); + if E2 > NoSignBit then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + end; + end; + + {set sign and exponent} + if E2 = 0 then + UB2[0] := 0 + else + UB2[0] := S2 or E2; + + Pack(UB2, E2, S2, Result); + end; +end; + +function BcdExt(const B : TBcd) : Extended; +var + Code : Integer; + S : string[59]; +begin + S := StrExpBcd(B, 0); + if ({$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator <> '.') then begin + while (pos({$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator, S) > 0) do + S[pos({$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator, S)] := '.'; + end; + Val(S, Result, Code); +end; + +procedure ConvertBcd(const SrcB; SrcSize : Byte; var DestB; DestSize : Byte); +label + Repack; +type + TBA = array[0..40] of Byte; {largest BCD size times 2} + PBA = ^TBA; +var + I, O, Exponent : Integer; + PS : PBA; + C : Byte; +begin + if (SrcSize = 0) or (DestSize = 0) then + exit; + + Exponent := TBA(SrcB)[0] and NoSignBit; + + {transfer mantissa} + if SrcSize <= DestSize then begin + {dest is at least as big as src} + FillChar(TBA(DestB)[1], DestSize-SrcSize, 0); + Move(TBA(SrcB)[1], TBA(DestB)[DestSize-SrcSize+1], SrcSize-1); + + end else begin + {need to round src before copying to dest} + GetMem(PS, 2*SrcSize); + + {unpack digits} + for I := 1 to SrcSize-1 do begin + PS^[2*I-1] := TBA(SrcB)[I] and $F; + PS^[2*I] := TBA(SrcB)[I] shr 4; + end; + {set last overflow digit to zero} + PS^[2*SrcSize-1] := 0; + {O is a shift used when rounding causes an overflow} + O := 0; + + {round src starting at most significant lost digit} + if PS^[SrcSize-DestSize] >= 5 then begin + {rounding has an effect} + C := 1; + for I := SrcSize-DestSize+1 to 2*(SrcSize-1) do begin + inc(PS^[I], C); + if PS^[I] > 9 then begin + dec(PS^[I], 10); + C := 1; + end else + {done rounding} + goto Repack; + end; + {set overflow digit if we get here} + PS^[2*SrcSize-1] := 1; + inc(Exponent); + O := 1; + end; + +Repack: + {repack into same buffer taking account of overflow offset} + for I := 1 to SrcSize-1 do + PS^[I] := PS^[2*I-1+O] or (PS^[2*I+O] shl 4); + + {copy rounded src into dest} + Move(PS^[SrcSize-DestSize+1], TBA(DestB)[1], DestSize-1); + + FreeMem(PS, 2*SrcSize); + end; + + {copy sign/exponent} + TBA(DestB)[0] := Exponent or (TBA(SrcB)[0] and SignBit); +end; + +function EqDigitsBcd(const B1, B2 : TBcd; Digits : Cardinal) : Boolean; +begin + Result := (CmpBcd(RoundDigitsBcd(B1, Digits), RoundDigitsBcd(B2, Digits)) = 0); +end; + +function EqPlacesBcd(const B1, B2 : TBcd; Digits : Cardinal) : Boolean; +begin + Result := (CmpBcd(RoundPlacesBcd(B1, Digits), RoundPlacesBcd(B2, Digits)) = 0); +end; + +function CmpBcd(const B1, B2 : TBcd) : Integer; +var +{$IFNDEF UseAsm} + I : Integer; +{$ENDIF} + E1, E2 : Integer; + S1, S2 : Byte; + UB1, UB2 : TUnpBcd; +begin + Unpack(B1, UB1, E1, S1); + Unpack(B2, UB2, E2, S2); + + if S1 <> S2 then + {signs differ} + Result := Integer(S2)-S1 + + else begin + {signs the same} + if E1 <> E2 then + {exponents differ} + Result := E1-E2 + + else if E1 = 0 then + {both numbers are zero} + Result := 0 + + else begin + {exponents the same, compare the mantissas} +{$IFDEF UseAsm} + asm + push esi + push edi + lea esi,UB1+MantissaDigits + lea edi,UB2+MantissaDigits + mov ecx,MantissaDigits +@1: mov al,[esi] + sub al,[edi] + jnz @2 + dec esi + dec edi + dec ecx + jnz @1 +@2: movsx eax,al + mov Result,eax + pop edi + pop esi + end; +{$ELSE} + for I := MantissaDigits downto 1 do begin + Result := Integer(UB1[I])-UB2[I]; + if Result <> 0 then + break; + end; +{$ENDIF} + end; + + if S1 <> 0 then + {both numbers negative, reverse the result} + Result := -Result; + end; +end; + +function ModBcd(const B1, B2 : TBcd) : TBcd; + {-Return B1 mod B2} +begin + Result := IntBcd(DivBcd(B1, B2)); +end; + +function DivBcd(const B1, B2 : TBcd) : TBcd; +{$IFNDEF UseAsm} +label + StoreDigit; +{$ENDIF} +var +{$IFNDEF UseAsm} + DivIntoCount, I, R : Integer; + T, C : ShortInt; + DDigit, NDigit : Byte; +{$ENDIF} + E1, E2, DivDigits, N : Integer; + S1, S2 : Byte; + UB1, UB2 : TUnpBcd; + TB : TIntBcd; +begin + if B2[0] = 0 then + {divide by zero} + RaiseBcdError(stscBcdDivByZero); + + if B1[0] = 0 then + {numerator is zero, return zero} + SetZero(Result) + + else begin + Unpack(B1, UB1, E1, S1); + Unpack(B2, UB2, E2, S2); + + {TB is the extended numerator} + FillChar(TB, 2*BcdSize, 0); + Move(UB1[1], TB[2*BcdSize], SigDigits); + + {UB1 is now used to store the result} + + {count significant mantissa digits in divisor} +{$IFDEF UseAsm} + asm + push edi + lea edi,UB2+1 + mov ecx,SigDigits + xor al,al + repe scasb + mov DivDigits,ecx + pop edi + end; +{$ELSE} + DivDigits := 0; + for I := 1 to MantissaDigits do + if UB2[I] <> 0 then begin + DivDigits := SigDigits-I; + break; + end; +{$ENDIF} + + if DivDigits = 0 then + {divide by zero, shouldn't have gotten here, but just in case...} + RaiseBcdError(stscBcdDivByZero); + +{$IFDEF UseAsm} + asm + push ebx + push esi + push edi + mov ecx,SigDigits {number of digits in result} + lea edi,UB1+SigDigits {edi points to MSD of result} + lea esi,TB+2*MantissaDigits+1 {esi points to MSD of numerator} + mov dh,byte ptr DivDigits {keep DivDigits in dh} + +@1: push ecx {save result counter} + push edi {save result position} + mov ebx,esi {save numerator position} + xor dl,dl {dl = number of times divisor fits into numerator} + +@2: cmp byte ptr [esi+1],0 {check for remainder in numerator} + jnz @4 {divisor guaranteed to fit again} + xor ecx,ecx + mov cl,dh {ecx = number of divisor digits} + lea edi,UB2+MantissaDigits {last digit of divisor} + +@3: mov al,[esi] {al = numerator digit} + dec esi + mov ah,[edi] {ah = divisor digit} + dec edi + cmp al,ah + ja @4 {divisor fits if numerator digit > divisor} + jb @7 {doesn't fit if numerator digit < divisor} + dec ecx + jnz @3 + +@4: inc dl {increment number of times divisor fits} + mov edi,ebx {restore numerator position to edi} + xor ecx,ecx + mov cl,dh {ecx = number of divisor digits} + lea esi,UB2+MantissaDigits {esi points to MSD of divisor} + dec ecx + sub esi,ecx {first significant digit of divisor} + sub edi,ecx {first active digit of numerator} + inc ecx + clc {no carry to start} + +@5: mov al,[edi] {al = digit from numerator} + sbb al,[esi] {subtract divisor from numerator} + aas + mov [edi],al {store back to numerator} + inc esi + inc edi + dec ecx + jnz @5 + jnc @6 + dec byte ptr [edi] {reduce last digit for borrow} + +@6: mov esi,ebx {restore numerator position to esi} + jmp @2 {see if divisor fits in numerator again} + +@7: mov esi,ebx {restore numerator position to esi} + pop edi {restore result position} + pop ecx {restore result counter} + mov [edi],dl {store times divisor went into numerator} + dec edi {next result digit} + dec esi {next numerator digit} + dec ecx + jnz @1 {compute next result digit} + + pop edi + pop esi + pop ebx + end; +{$ELSE} + {start with most significant digit of numerator} + N := 2*MantissaDigits+1; + + {iterate until the result mantissa is filled} + for R := SigDigits downto 1 do begin + DivIntoCount := 0; + + repeat + {subtract divisor from current numerator position as many times as possible} + if TB[N+1] = 0 then begin + {no overflow digit in this position of numerator} + for I := 0 to DivDigits-1 do begin + DDigit := UB2[MantissaDigits-I]; + NDigit := TB[N-I]; + if DDigit < NDigit then + {divisor still fits} + break + else if DDigit > NDigit then + {divisor doesn't fit} + goto StoreDigit; + end; + end; + inc(DivIntoCount); + + {subtract divisor once from numerator} + C := 0; + for I := DivDigits-1 downto 0 do begin + T := TB[N-I]-UB2[MantissaDigits-I]-C; + if T < 0 then begin + C := 1; + inc(T, 10); + end else + C := 0; + TB[N-I] := T; + end; + {reduce last digit for borrow} + dec(TB[N+1], C); + until False; + +StoreDigit: + {store this digit of result} + UB1[R] := DivIntoCount; + {next numerator digit} + dec(N); + end; +{$ENDIF} + + if UB1[SigDigits] <> 0 then begin + {round away the temporary digit} + RoundMantissa(UB1, 1); + ShiftMantissaDown(UB1, 1); + inc(E1); + end; + + {compute exponent} + N := E1-E2+ExpBias; + if N > NoSignBit then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + Pack(UB1, N, S1 xor S2, Result); + end; +end; + +function FastVal(const S : string) : TBcd; + {-Internal routine to quickly convert a string constant to a Bcd} + {Assumes no leading spaces, + no leading '+', + no leading '.', + always contains decimal point defined by international DecimalSeparator, + no invalid characters, + no exponent, + < MantissaDigits before decimal point} +var + I, O, Digits, Exponent : Integer; + Sign : Byte; + Rounded : Boolean; + UB : TUnpBcd; + + procedure AddDigit(Ch : Char); + begin + if O > 0 then begin + UB[O] := Byte(Ch)-Byte('0'); + dec(O); + end else if not Rounded then begin + {got more significant digits than will fit, must round} + Rounded := True; + UB[0] := Byte(Ch)-Byte('0'); + RoundMantissa(UB, 0); + if UB[SigDigits] <> 0 then begin + ShiftMantissaDown(UB, 1); + inc(Digits); + end; + end; + end; + +begin + FillChar(UB, SizeOf(TUnpBcd), 0); + + O := MantissaDigits; + Rounded := False; + Digits := 0; + + {get sign if any} + if S[1] = '-' then begin + Sign := SignBit; + I := 2; + end else begin + Sign := 0; + I := 1; + end; + + {skip leading zeros} + while S[I] = '0' do + inc(I); + + {add significant digits} + while S[I] <> '.' do begin + AddDigit(S[I]); + inc(I); + inc(Digits); + end; + + {handle dot} + inc(I); + if Digits = 0 then + {no digits before dot, skip zeros after dot} + while (I <= length(S)) and (S[I] = '0') do begin + inc(I); + dec(Digits); + end; + + {add significant digits} + while I <= Length(S) do begin + AddDigit(S[I]); + if Rounded then + break; + inc(I); + end; + + {compute final exponent} + Exponent := Digits+ExpBias; + + if (Exponent <= 0) or IsZeroMantissa(UB) then + {return zero} + Exponent := 0; + + {Return packed result} + Pack(UB, Exponent, Sign, Result); +end; + +function ExpBcd(const B : TBcd) : TBcd; +var + MI, Exponent : LongInt; + B1, B2, B3, B4, B5 : TBcd; +begin + if CmpBcd(B, FastVal('147.36')) > 0 then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + + if CmpBcd(B, FastVal('-145.06')) < 0 then begin + {return zero} + SetZero(Result); + Exit; + end; + + if B[0] = 0 then begin + {return one} + Result := FastVal('1.0'); + Exit; + end; + +{If BcdSize > 10, Delphi 2.0 generates a hint (if hints on) about B3 during compile} +{this can be ignored or you can suppress warnings in STDEFINE.INC} +{or suppress hints and warning for the IF..THEN block} + + if BcdSize <= 10 then begin + {Burns (Cody-Waite) approximation} + Exponent := RoundBcd(MulBcd(B, FastVal('0.868588963806503655'))); + MI := Exponent; {prevent D32 from generating a hint} + B5 := LongBcd(MI); + + B3 := AddBcd(B, MulBcd(B5, FastVal('-1.151'))); + B1 := AddBcd(B3, MulBcd(B5, FastVal('-0.000292546497022842009'))); + B2 := MulBcd(B1, B1); + + B3 := MulBcd(B2, FastVal('42.0414268137450315')); + B3 := MulBcd(B2, AddBcd(B3, FastVal('10097.4148724273918'))); + B4 := MulBcd(B1, AddBcd(B3, FastVal('333267.029226801611'))); + + B3 := MulBcd(B2, AddBcd(B2, FastVal('841.243584514154545'))); + B3 := MulBcd(B2, AddBcd(B3, FastVal('75739.3346159883444'))); + B3 := AddBcd(B3, FastVal('666534.058453603223')); + B3 := DivBcd(B4, SubBcd(B3, B4)); + Result := MulBcd(AddBcd(B3, FastVal('0.5')), FastVal('2.0')); + + if Odd(MI) then begin + if MI < 0 then + Result := DivBcd(Result, FastVal('3.16227766016837933')) + else + Result := MulBcd(Result, FastVal('3.16227766016837933')); + end; + + inc(ShortInt(Result[0]), MI div 2); + + end else begin + {series approximation} + {compute B2, a number whose exp is close to 1.0} + {and MI, a number whose exp is a power of 10} + B2 := DivBcd(B, Ln10Bcd); + if B[0] and SignBit <> 0 then + B2 := SubBcd(B2, FastVal('0.5')) + else + B2 := AddBcd(B2, FastVal('0.5')); + MI := TruncBcd(B2); + B2 := SubBcd(B, MulBcd(IntBcd(B2), Ln10Bcd)); + + {compute exp(B2)} + B1 := FastVal('1.0'); + B4 := B1; + Result := B1; + B5 := B2; + while B5[0] and NoSignBit > ExpBias-MantissaDigits-1 do begin + Result := AddBcd(Result, B5); + B4 := AddBcd(B4, B1); + B5 := DivBcd(MulBcd(B5, B2), B4); + end; + + {correct exponent for 10**MI} + Exponent := Result[0] and NoSignBit; + inc(Exponent, MI); + if Exponent > NoSignBit then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + if Exponent <= 0 then + {underflow} + SetZero(Result); + Result[0] := Exponent; + end; +end; + +function ExtBcd(E : Extended) : TBcd; +var + S : string; +begin + Str(e:0:MantissaDigits, S); + Result := ValBcd(FastValPrep(S)); +end; + +function StrGeneralBcd(const B : TBcd) : string; +var + I, EndI, Exponent : Integer; + + procedure RemoveTrailingZeros(StartI, EndI : Integer); + var + I : Integer; + begin + I := StartI; + while (I > 0) and (Result[I] = '0') and (Result[I] <> {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator) do + dec(I); + if Result[I] = {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator then + dec(I); + Delete(Result, I+1, EndI-I); + end; + +begin + Exponent := B[0] and NoSignBit; + + if (Exponent = 0) or + ((Exponent <= MantissaDigits+ExpBias) and (Exponent >= ExpBias-4)) then begin + {use fixed point format for zero, digits to left of decimal point greater + than or equal to MantissaDigits, or value greater than 0.00001} + Result := StrBcd(B, 0, MantissaDigits); + RemoveTrailingZeros(Length(Result), Length(Result)); + + end else begin + {otherwise use scientific format} + Result := StrExpBcd(B, 0); + if Result[1] = ' ' then + Delete(Result, 1, 1); + I := Length(Result)-1; + EndI := I-3; + while (I <= Length(Result)) and (Result[I] = '0') do + Delete(Result, I, 1); + if I > Length(Result) then begin + {exponent was all zero} + Delete(Result, Length(Result)-1, 2); + I := Length(Result); + end else + {skip back over "e+"} + I := EndI; + RemoveTrailingZeros(I, EndI); + end; +end; + +function FormatBcd(const Format: string; const B : TBcd): string; +label + Restart; +var + SectNum, SectOfs, I, ExpDigits, ActPlaces : Integer; + DigitCount, DecimalIndex, FirstDigit, LastDigit : Integer; + DigitPlace, DigitDelta, Exponent : Integer; + BufOfs, UBOfs : Integer; + ThousandSep, Scientific : Boolean; + Ch : Char; + Sign : Byte; + UB : TUnpBcd; + SExponent : string;//[4]; + Buffer : array[0..255] of Char; + + function FindSection(SectNum : Integer) : Integer; + {-Return the offset into Format for the given section number} + var + Ch : Char; + begin + if SectNum > 0 then begin + Result := 1; + while Result <= Length(Format) do begin + Ch := Format[Result]; + case Ch of + {labels in ASCII order so 32-bit compiler generates better code} + '"', '''' : {skip literal} + begin + inc(Result); + while (Result <= Length(Format)) and (Format[Result] <> Ch) do + inc(Result); + if Result > Length(Format) then + break; + end; + ';' : {end of section} + begin + dec(SectNum); + if SectNum = 0 then begin + inc(Result); + if (Result > Length(Format)) or (Format[Result] = ';') then + {empty section} + break + else + {found the section, return its offset} + exit; + end; + end; + end; + inc(Result); + end; + end; + + {arrive here if desired section is empty, not found, or ill-formed} + if (Length(Format) = 0) or (Format[1] = ';') then + {first section is empty, use general format} + Result := 0 + else + {use first section} + Result := 1; + end; + + procedure ScanSection(SectOfs : Integer); + {-Initialize DigitCount, DecimalIndex, ThousandSep, + Scientific, FirstDigit, LastDigit} + var + FirstZero, LastZero : Integer; + Ch : Char; + begin + FirstZero := 32767; + LastZero := 0; + DigitCount := 0; + DecimalIndex := -1; + ThousandSep := False; + Scientific := False; + + repeat + Ch := Format[SectOfs]; + case Ch of + {labels in ASCII order so 32-bit compiler generates better code} + '"' : + begin + inc(SectOfs); + while (SectOfs <= Length(Format)) and (Format[SectOfs] <> Ch) do + inc(SectOfs); + if SectOfs > Length(Format) then + break; + end; + + '#' : + inc(DigitCount); + + '''' : + begin + inc(SectOfs); + while (SectOfs <= Length(Format)) and (Format[SectOfs] <> Ch) do + inc(SectOfs); + if SectOfs > Length(Format) then + break; + end; + + '0' : + begin + if DigitCount < FirstZero then + FirstZero := DigitCount; + inc(DigitCount); + LastZero := DigitCount; + end; + + ';' : + break; + + 'E', 'e' : + if SectOfs < Length(Format) then begin + inc(SectOfs); + case Format[SectOfs] of + '-', '+' : + begin + Scientific := True; + repeat + inc(SectOfs); + until (SectOfs > Length(Format)) or (Format[SectOfs] <> '0'); + end; + else + {back up and look at character after 'e' again} + dec(SectOfs); + end; + end; + else + if Ch = {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}ThousandSeparator then + ThousandSep := True; + + if Ch = {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator then + if DecimalIndex = -1 then + DecimalIndex := DigitCount; + end; + + inc(SectOfs); + if SectOfs > Length(Format) then + break; + until False; + + if DecimalIndex = -1 then + DecimalIndex := DigitCount; + LastDigit := DecimalIndex-LastZero; + if LastDigit > 0 then + LastDigit := 0; + FirstDigit := DecimalIndex-FirstZero; + if FirstDigit < 0 then + FirstDigit := 0; + end; + + procedure StoreChar(Ch : Char); + begin + if BufOfs >= Length(Buffer) then + {buffer overrun} + RaiseBcdError(stscBcdBufOverflow); + Buffer[BufOfs] := Ch; + inc(BufOfs); + end; + + procedure StoreDigitReally(ReadUB : Boolean); + var + BVal : Byte; + begin + if ReadUB then begin + if UBOfs >= 0 then begin + BVal := UB[UBOfs]; + dec(UBOfs); + end else if DigitPlace <= LastDigit then begin + dec(DigitPlace); + Exit; + end else + BVal := 0; + end else + BVal := 0; + + if DigitPlace = 0 then begin + StoreChar({$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator); + StoreChar(Char(BVal+Byte('0'))); + end else begin + StoreChar(Char(BVal+Byte('0'))); + if ThousandSep then + if DigitPlace > 1 then + if DigitPlace mod 3 = 1 then + StoreChar({$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}ThousandSeparator); + end; + + dec(DigitPlace); + end; + + procedure StoreDigit; + begin + if DigitDelta = 0 then + StoreDigitReally(True) + else if DigitDelta < 0 then begin + inc(DigitDelta); + if DigitPlace <= FirstDigit then + StoreDigitReally(False) + else + dec(DigitPlace); + end else begin + repeat + StoreDigitReally(True); + dec(DigitDelta); + until DigitDelta = 0; + StoreDigitReally(True); + end; + end; + +begin + Unpack(B, UB, Exponent, Sign); + +Restart: + if Exponent = 0 then + {zero} + SectNum := 2 + else if Sign <> 0 then + {negative} + SectNum := 1 + else + {positive} + SectNum := 0; + SectOfs := FindSection(SectNum); + + if SectOfs = 0 then + {general floating point format} + Result := StrGeneralBcd(B) + + else begin + {scan the section once to determine critical format properties} + ScanSection(SectOfs); + + if Exponent <> 0 then begin + {round based on number of displayed digits} + ActPlaces := Integer(MantissaDigits)-Exponent+ExpBias; + if DigitCount-DecimalIndex < ActPlaces then begin + RoundMantissa(UB, ActPlaces-(DigitCount-DecimalIndex)); + if UB[SigDigits] <> 0 then begin + ShiftMantissaDown(UB, 1); + inc(Exponent); + end else if IsZeroMantissa(UB) then begin + {rounded to zero, possibly use a different mask} + Exponent := 0; + goto Restart; + end; + end; + end; + + {apply formatting} + if Scientific then begin + DigitPlace := DecimalIndex; + DigitDelta := 0; + if Exponent = 0 then + {for input = 0, display E+00} + Exponent := ExpBias+1 + end else begin + if Exponent = 0 then + {special case for input = 0} + Exponent := ExpBias + else if Exponent-ExpBias > MantissaDigits then begin + {all digits are integer part} + Result := StrGeneralBcd(B); + Exit; + end; + DigitPlace := Exponent-ExpBias; + DigitDelta := DigitPlace-DecimalIndex; + if DigitPlace < DecimalIndex then + DigitPlace := DecimalIndex; + end; + + BufOfs := 0; + UBOfs := MantissaDigits; + + if Sign <> 0 then + if SectOfs = 1 then + StoreChar('-'); + + repeat + Ch := Format[SectOfs]; + case Ch of + {labels in ASCII order so 32-bit compiler generates better code} + '"' : + begin + inc(SectOfs); + while (SectOfs <= Length(Format)) and (Format[SectOfs] <> Ch) do begin + StoreChar(Format[SectOfs]); + inc(SectOfs); + end; + if SectOfs > Length(Format) then + break; + end; + '#' : + StoreDigit; + + '''' : + begin + inc(SectOfs); + while (SectOfs <= Length(Format)) and (Format[SectOfs] <> Ch) do begin + StoreChar(Format[SectOfs]); + inc(SectOfs); + end; + if SectOfs > Length(Format) then + break; + end; + + '0' : + StoreDigit; + + ';' : + break; + + 'E', 'e' : + if SectOfs < Length(Format) then begin + inc(SectOfs); + case Format[SectOfs] of + '-', '+' : + begin + StoreChar(Ch); + Ch := Format[SectOfs]; + ExpDigits := -1; + repeat + inc(ExpDigits); + inc(SectOfs); + until (SectOfs > Length(Format)) or (Format[SectOfs] <> '0'); + if ExpDigits > 4 then + ExpDigits := 4; + dec(Exponent, ExpBias+DecimalIndex); + if (Exponent >= 0) and (Ch = '+') then + StoreChar('+'); + if Exponent < 0 then begin + StoreChar('-'); + Exponent := Abs(Exponent); + end; + Str(Exponent:ExpDigits, SExponent); + for I := 1 to ExpDigits do + if SExponent[I] = ' ' then + StoreChar('0') + else + StoreChar(SExponent[I]); + end; + else + StoreChar(Ch); + StoreChar(Format[SectOfs]); + end; + end else + StoreChar(Ch); + else + {these characters are automatically inserted in StoreDigit}; + if not (Ch in [{$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}ThousandSeparator, {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator]) then + StoreChar(Ch); + end; + + inc(SectOfs); + if SectOfs > Length(Format) then + break; + until False; + + SetLength(Result, BufOfs); + move(Buffer[0], Result[1], BufOfs * SizeOf(Char)); + end; +end; + +function FracBcd(const B : TBcd) : TBcd; +begin + Result := SubBcd(B, IntBcd(B)); +end; + +function IsIntBcd(const B : TBcd) : Boolean; +var +{$IFNDEF UseAsm} + I : Integer; +{$ENDIF} + Exponent : Integer; + Sign : Byte; + UB : TUnpBcd; +begin + Unpack(B, UB, Exponent, Sign); + + if Exponent = 0 then + {0.0 has no fractional part} + Result := True + + else if Exponent <= ExpBias then + {value is less than one, but non-zero} + Result := False + + else if Exponent-ExpBias >= MantissaDigits then + {entire mantissa is non-fractional} + Result := True + + else begin + {see if any non-zero digits to left of decimal point} +{$IFDEF UseAsm} + asm + push edi + lea edi,UB+1 + mov ecx,MantissaDigits+ExpBias + sub ecx,Exponent + xor al,al + cld + repe scasb + jne @1 + inc al +@1: mov Result,al + pop edi + end; +{$ELSE} + for I := 1 to MantissaDigits-(Exponent-ExpBias) do + if UB[I] <> 0 then begin + Result := False; + Exit; + end; + Result := True; +{$ENDIF} + end; +end; + +function IntBcd(const B : TBcd) : TBcd; +var + Exponent : Integer; + Sign : Byte; + UB : TUnpBcd; +begin + Unpack(B, UB, Exponent, Sign); + + if Exponent <= ExpBias then + {value is less than one} + SetZero(Result) + + else if Exponent-ExpBias >= MantissaDigits then + {entire mantissa is integer part} + Result := B + + else begin + {clear fractional digits} + FillChar(UB[1], MantissaDigits-(Exponent-ExpBias), 0); + Pack(UB, Exponent, Sign, Result); + end; +end; + +function IntPowBcd(const B : TBcd; E : LongInt) : TBcd; +var + I : LongInt; + B1 : TBcd; +begin + B1 := FastVal('1.0'); + Result := B1; + for I := 1 to Abs(E) do + Result := MulBcd(Result, B); + if E < 0 then + Result := DivBcd(B1, Result); +end; + +function LnBcd20(const B : TBcd) : TBcd; +const + Iterations = 9; +var + Exponent, N, K : integer; + BN, B025, B05, B1, AN, GN, Pow : TBcd; + DN1, DN : array[0..Iterations] of TBcd; +begin + {normalize input in range 0.10-0.99...} + Exponent := B[0]-ExpBias; + BN := B; + BN[0] := ExpBias; + + {initialize some constants} + B025 := FastVal('0.25'); + B05 := FastVal('0.5'); + B1 := FastVal('1.0'); + + {compute initial terms of approximation} + AN := MulBcd(B05, AddBcd(BN, B1)); + GN := SqrtBcd(BN); + DN1[0] := AN; + + {converge on exact value} + for N := 1 to Iterations do begin + AN := MulBcd(B05, AddBcd(AN, GN)); + DN[0] := AN; + Pow := B025; + for K := 1 to N do begin + DN[K] := DivBcd(SubBcd(DN[K-1], MulBcd(Pow, DN1[K-1])), SubBcd(B1, Pow)); + if K = N then + break; + Pow := MulBcd(Pow, B025); + end; + + if N = Iterations then + break; + GN := SqrtBcd(MulBcd(AN, GN)); + DN1 := DN; + end; + Result := DivBcd(SubBcd(BN, B1), DN[Iterations]); + + {correct for normalization} + Result := AddBcd(Result, MulBcd(LongBcd(Exponent), Ln10Bcd)); +end; + +function LnBcd10(const B : TBcd) : TBcd; +var + Exponent : Integer; + BN, B1, S, W, T, AW, BW : TBcd; +begin + {normalize input in range 0.10-0.99...} + Exponent := B[0]-ExpBias; + BN := B; + BN[0] := ExpBias; + + if CmpBcd(BN, FastVal('0.316227766016837933')) < 0 then begin + {renormalize in range .316-3.16} + dec(Exponent); + inc(BN[0]); + end; + + B1 := FastVal('1.0'); + S := DivBcd(SubBcd(BN, B1), AddBcd(BN, B1)); + W := MulBcd(S, S); + + T := MulBcd(W, FastVal('-0.741010784161919239')); + T := MulBcd(W, AddBcd(T, FastVal('10.3338571514793865'))); + T := MulBcd(W, AddBcd(T, FastVal('-39.273741020315625'))); + T := MulBcd(W, AddBcd(T, FastVal('55.4085912041205931'))); + AW := AddBcd(T, FastVal('-26.0447002405557636')); + + T := MulBcd(W, AddBcd(W, FastVal('-19.3732345832854786'))); + T := MulBcd(W, AddBcd(T, FastVal('107.109789115668009'))); + T := MulBcd(W, AddBcd(T, FastVal('-244.303035341829542'))); + T := MulBcd(W, AddBcd(T, FastVal('245.347618868489348'))); + BW := AddBcd(T, FastVal('-89.9552077881033117')); + + T := MulBcd(W, DivBcd(AW, BW)); + T := MulBcd(S, AddBcd(T, FastVal('0.868588963806503655'))); + + Result := MulBcd(AddBcd(T, LongBcd(Exponent)), Ln10Bcd); +end; + +function LnBcd(const B : TBcd) : TBcd; +begin + if (B[0] = 0) or (B[0] and SignBit <> 0) then + {ln of zero or a negative number} + RaiseBcdError(stscBcdBadInput); + + if BcdSize <= 10 then + Result := LnBcd10(B) + else + Result := LnBcd20(B); +end; + +function LongBcd(L : LongInt) : TBcd; +var + S : string; +begin + Str(L, S); + Result := ValBcd(FastValPrep(S)); +end; + +function MulBcd(const B1, B2 : TBcd) : TBcd; +var + E1, E2, Digits : Integer; + S1, S2 : Byte; +{$IFNDEF UseAsm} + I1, I2 : Integer; + CP, CN : Byte; + T, T1, T2 : Byte; +{$ENDIF} + PB : PUnpBcd; + UB1, UB2 : TUnpBcd; + TB : TIntBcd; +begin + if (B1[0] = 0) or (B2[0] = 0) then + SetZero(Result) + + else begin + Unpack(B1, UB1, E1, S1); + Unpack(B2, UB2, E2, S2); + + FillChar(TB, SizeOf(TIntBcd), 0); + + {multiply and sum the mantissas} +{$IFDEF UseAsm} + asm + push ebx + push esi + push edi + lea ebx,UB1 {multiplier} + lea edi,TB {result} + mov ecx,MantissaDigits + +@1: inc ebx {next multiplier digit} + inc edi {next output digit} + mov al,[ebx] {get next multiplier digit} + or al,al {if zero, nothing to do} + jz @3 + + push ecx {save digit counter} + mov dl,al {save multiplier} + lea esi,UB2+1 {multiplicand} + mov ecx,MantissaDigits + xor dh,dh + +@2: mov al,[esi] {next multiplicand digit} + inc esi + mul dl {multiply by multiplier, overflow in ah} + aam + add al,[edi] {add previous result} + aaa + add al,dh {add previous overflow} + aaa + mov [edi],al {store temporary result} + inc edi + mov dh,ah {save overflow for next time} + dec ecx + jnz @2 + mov [edi],dh {save last overflow in next digit} + sub edi,MantissaDigits {reset output offset for next multiplier} + pop ecx + +@3: dec ecx {next multiplier digit} + jnz @1 + pop edi + pop esi + pop ebx + end; +{$ELSE} + for I1 := 1 to MantissaDigits do begin + T1 := UB1[I1]; + if T1 <> 0 then begin + CP := 0; + for I2 := 1 to MantissaDigits do begin + T := T1*UB2[I2]; + T2 := T mod 10; + CN := T div 10; + inc(T2, TB[I1+I2-1]); + if T2 > 9 then begin + dec(T2, 10); + inc(CN); + end; + inc(T2, CP); + if T2 > 9 then begin + dec(T2, 10); + inc(CN); + end; + TB[I1+I2-1] := T2; + CP := CN; + end; + {store last carry in next digit of buffer} + TB[I1+MantissaDigits] := CP; + end; + end; +{$ENDIF} + + {normalize the product} + if TB[2*MantissaDigits] <> 0 then begin + PB := PUnpBcd(@TB[MantissaDigits]); + Digits := 0; + end else begin + PB := PUnpBcd(@TB[MantissaDigits-1]); + Digits := -1; + end; + RoundMantissa(PB^, 0); + if PB^[SigDigits] <> 0 then begin + inc(PByte(PB)); + inc(Digits); + end; + {copy back to UB2} + UB2 := PB^; + + {set sign and exponent} + inc(E2, E1+Digits-ExpBias); + if E2 > NoSignBit then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + + Pack(UB2, E2, S1 xor S2, Result); + end; +end; + +function NegBcd(const B : TBcd) : TBcd; +begin + Result := B; + if B[0] <> 0 then + Result[0] := B[0] xor SignBit; +end; + +function PowBcd(const B, E : TBcd) : TBcd; +begin + if E[0] = 0 then + {anything raised to the zero power is 1.0} + Result := FastVal('1.0') + + else if IsIntBcd(E) then + {compute the power by simple multiplication} + Result := IntPowBcd(B, TruncBcd(E)) + + else begin + if B[0] and SignBit <> 0 then + {negative number raised to a non-integer power} + RaiseBcdError(stscBcdBadInput); + + Result := ExpBcd(MulBcd(E, LnBcd(B))); + end; +end; + +function RoundBcd(const B : TBcd) : LongInt; +var + Exponent, I : Integer; + Sign : Byte; + UB : TUnpBcd; +begin + Unpack(B, UB, Exponent, Sign); + + Result := 0; + if Exponent <> 0 then begin + {Bcd is not zero} + I := MantissaDigits; + {add digits to left of decimal point} + while (I >= 1) and (Exponent > ExpBias) do begin + if Abs(Result) > MaxLongInt div 10 then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + Result := 10*Result; + if Sign <> 0 then begin + if Result < -MaxLongInt-1+UB[I] then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + dec(Result, UB[I]); + end else begin + if Result > MaxLongInt-UB[I] then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + inc(Result, UB[I]); + end; + dec(I); + dec(Exponent); + end; + + {round last digit} + if (I >= 1) and (Exponent = ExpBias) and (UB[I] >= 5) then begin + if Sign <> 0 then begin + if Result = -MaxLongInt-1 then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + dec(Result); + end else begin + if Result = MaxLongInt then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + inc(Result); + end; + end; + + end; +end; + +function RoundDigitsBcd(const B : TBcd; Digits : Cardinal) : TBcd; +var + Exponent : Integer; + Sign : Byte; + UB : TUnpBcd; +begin + if B[0] = 0 then + {input is zero} + SetZero(Result) + + else if Digits >= MantissaDigits then + {no actual rounding} + Result := B + + else begin + Unpack(B, UB, Exponent, Sign); + + {treat 0 digits same as 1} + if Digits = 0 then + Digits := 1; + + RoundMantissa(UB, MantissaDigits-Digits); + if UB[SigDigits] <> 0 then begin + ShiftMantissaDown(UB, 1); + inc(Exponent); + end else if IsZeroMantissa(UB) then + Exponent := 0; + + Pack(UB, Exponent, Sign, Result); + end; +end; + +function RoundPlacesBcd(const B : TBcd; Places : Cardinal) : TBcd; +var + Exponent, ActPlaces : Integer; + Sign : Byte; + UB : TUnpBcd; +begin + if B[0] = 0 then + {input is zero} + SetZero(Result) + + else begin + ActPlaces := Integer(MantissaDigits)-(B[0] and NoSignBit)+ExpBias; + + if LongInt(Places) >= ActPlaces then + {no actual rounding} + Result := B + + else begin + Unpack(B, UB, Exponent, Sign); + + RoundMantissa(UB, ActPlaces-LongInt(Places)); + if UB[SigDigits] <> 0 then begin + ShiftMantissaDown(UB, 1); + inc(Exponent); + end else if IsZeroMantissa(UB) then + Exponent := 0; + + Pack(UB, Exponent, Sign, Result); + end; + end; +end; + +function SqrtBcd(const B : TBcd) : TBcd; +var + Exponent, I, Iterations : Integer; + BN, B05 : TBcd; +begin + if B[0] and SignBit <> 0 then + {square root of a negative number} + RaiseBcdError(stscBcdBadInput); + + if B[0] = 0 then begin + {done for input of zero} + SetZero(Result); + Exit; + end; + + {normalize input} + Exponent := B[0]-ExpBias; + BN := B; + BN[0] := ExpBias; + + {create reused constant bcd} + B05 := FastVal('0.5'); + + {compute initial approximation of sqrt} + Result := AddBcd(MulBcd(FastVal('0.894470'), BN), + FastVal('0.223607')); + + if BcdSize <= 10 then + Iterations := 3 + else + Iterations := 5; + + {iterate to accurate normalized sqrt, Result = 0.5*((BN/Result)+Result)} + for I := 1 to Iterations do + Result := MulBcd(AddBcd(DivBcd(BN, Result), Result), B05); + + {final correction Result = (0.5*(BN/Result-Result))+Result} + Result := AddBcd(MulBcd(SubBcd(DivBcd(BN, Result), Result), B05), Result); + + if Odd(Exponent) then begin + Result := MulBcd(Result, + FastVal('0.31622776601683793319988935444327185337')); {Sqrt(0.1)} + inc(Exponent); + end; + + inc(Result[0], Exponent shr 1); +end; + +function StrBcd(const B : TBcd; Width, Places : Cardinal) : string; +var + I, O, Exponent, ActWidth, Digits, DecimalPos : Integer; + Sign : Byte; + UB : TUnpBcd; + + procedure AddChar(Ch : Char); + begin + Result[O] := Ch; + inc(O); + end; + +begin + Unpack(B, UB, Exponent, Sign); + + if Exponent = 0 then begin + {ensure mantissa is set to zero} + FillChar(UB[1], SigDigits, 0); + {fool the rest of the function} + Exponent := ExpBias+1; + end; + + {ActWidth is the non-padded width} + {it has at least one digit before decimal point} + ActWidth := 1; + if Exponent > ExpBias+1 then + {add other digits before decimal point} + inc(ActWidth, Exponent-ExpBias-1); + + {add digits after decimal point} + inc(ActWidth, Places); + + {see how many digits from mantissa to use} + if Exponent < ExpBias+1 then begin + Digits := LongInt(Places)-(ExpBias-Exponent); + if Digits < 0 then + Digits := 0; + end else + Digits := ActWidth; + + if Places <> 0 then + {add one for decimal point} + inc(ActWidth); + + if Sign <> 0 then + {add one for minus sign} + inc(ActWidth); + + if Digits < MantissaDigits then begin + {need to round} + RoundMantissa(UB, MantissaDigits-Digits); + if UB[SigDigits] <> 0 then begin + ShiftMantissaDown(UB, 1); + inc(Exponent); + inc(Digits); + if Exponent > ExpBias+1 then + inc(ActWidth); + end; + end else + {use all mantissa digits} + Digits := MantissaDigits; + + {adjust and limit Width} + if Width = 0 then + Width := ActWidth; +{$IFDEF WStrings} + if Width > 255 then + Width := 255; +{$ENDIF} + SetLength(Result, Width); + + if LongInt(Width) < ActWidth then begin + {result won't fit in specified width} + Result := StringOfChar(OverflowChar, Length(Result)); //FillChar(Result[1], Length(Result) * SizeOf(Char), OverflowChar); + Exit; + end; + + if LongInt(Width) > ActWidth then begin + {store leading spaces} + StrPCopy(PChar(Result), StringOfChar(' ', LongInt(Width)-ActWidth)); //FillChar(Result[1], LongInt(Width)-ActWidth, ' '); + O := LongInt(Width)-ActWidth+1; + end else + O := 1; + + if Sign <> 0 then + AddChar('-'); + + if Exponent < ExpBias+1 then begin + {number is less than 1} + AddChar('0'); + if Exponent <> 0 then begin + AddChar({$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator); + for I := 1 to ExpBias-Exponent do + if O <= LongInt(Width) then + AddChar('0'); + end; + end; + + if Places = 0 then + {no decimal point} + DecimalPos := 0 + else + DecimalPos := Width-Places; + + {add digits from the mantissa} + if Digits <> 0 then begin + I := SigDigits; + if UB[I] = 0 then + dec(I); + while (Digits > 0) and (O <= LongInt(Width)) do begin + if O = DecimalPos then + AddChar({$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator); + AddChar(Char(UB[I]+Byte('0'))); + dec(I); + dec(Digits); + end; + end; + + {add trailing zeros, if any} + while O <= LongInt(Width) do begin + if O = DecimalPos then + AddChar({$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator); + if O <= LongInt(Width) then + AddChar('0'); + end; +end; + +function StrExpBcd(const B : TBcd; Width : Cardinal) : string; +const + MinWidth = 8; + MaxWidth = MantissaDigits+6; +var + I, O, Exponent : Integer; + Sign : Byte; + UB : TUnpBcd; + + procedure AddChar(Ch : Char); + begin + Result[O] := Ch; + inc(O); + end; + +begin + Unpack(B, UB, Exponent, Sign); + + {validate and adjust Width} + if Width = 0 then + Width := MaxWidth + else if Width < MinWidth then + Width := MinWidth; +{$IFDEF WStrings} + if Width > 255 then + Width := 255; +{$ENDIF} + SetLength(Result, Width); + + {store leading spaces} + if Width > MaxWidth then begin + StrPCopy(PChar(Result), StringOfChar(' ', Width-MaxWidth)); //FillChar(Result[1], Width-MaxWidth, ' '); + O := Width-MaxWidth+1; + end else + O := 1; + + {store sign} + if Sign <> 0 then + AddChar('-') + else + AddChar(' '); + + if Exponent = 0 then begin + {ensure mantissa is set to zero} + FillChar(UB[1], SigDigits, 0); + {force Exponent to display as 0} + Exponent := ExpBias+1; + + end else if Width < MaxWidth then begin + {need to round} + RoundMantissa(UB, MaxWidth-Width); + if UB[SigDigits] <> 0 then begin + ShiftMantissaDown(UB, 1); + inc(Exponent); + end; + end; + + {copy mantissa to string} + I := MantissaDigits; + AddChar(Char(UB[I]+Byte('0'))); + dec(I); + AddChar({$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator); + while O < LongInt(Width-3) do begin + AddChar(Char(UB[I]+Byte('0'))); + dec(I); + end; + + {store exponent} + AddChar('E'); + if Exponent < ExpBias+1 then begin + AddChar('-'); + Exponent := ExpBias+1-Exponent; + end else begin + AddChar('+'); + dec(Exponent, ExpBias+1); + end; + AddChar(Char((Exponent div 10)+Byte('0'))); + AddChar(Char((Exponent mod 10)+Byte('0'))); +end; + +function SubBcd(const B1, B2 : TBcd) : TBcd; +begin + Result := AddBcd(B1, NegBcd(B2)); +end; + +function TruncBcd(const B : TBcd) : LongInt; +var + Exponent, I : Integer; + Sign : Byte; + UB : TUnpBcd; +begin + Unpack(B, UB, Exponent, Sign); + + Result := 0; + if Exponent <> 0 then begin + {Bcd is not zero} + I := MantissaDigits; + {Add digits to left of decimal point} + while (I >= 1) and (Exponent > ExpBias) do begin + if Abs(Result) > MaxLongInt div 10 then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + Result := 10*Result; + if Sign <> 0 then begin + if Result < -MaxLongInt-1+UB[I] then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + dec(Result, UB[I]); + end else begin + if Result > MaxLongInt-UB[I] then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + inc(Result, UB[I]); + end; + + dec(I); + dec(Exponent); + end; + end; +end; + +function ValBcd(const S : string) : TBcd; +var + I, O, Digits, Exponent : Integer; + Sign : Byte; + ExpSigned, Rounded : Boolean; + UB : TUnpBcd; + + function SChar(I : Integer) : Char; + begin + if I > Length(S) then + Result := #0 + else + Result := S[I]; + end; + + function IsDigit(Ch : Char) : Boolean; + begin + Result := (Ch >= '0') and (Ch <= '9'); + end; + + procedure AddDigit(Ch : Char); + begin + if O > 0 then begin + UB[O] := Byte(Ch)-Byte('0'); + dec(O); + end else if not Rounded then begin + {got more significant digits than will fit, must round} + Rounded := True; + UB[0] := Byte(Ch)-Byte('0'); + RoundMantissa(UB, 0); + if UB[SigDigits] <> 0 then begin + ShiftMantissaDown(UB, 1); + inc(Digits); + end; + end; + end; + +begin + FillChar(UB, SizeOf(TUnpBcd), 0); + + I := 1; {input position} + O := MantissaDigits; {output position} + Exponent := 0; + Sign := 0; + Rounded := False; + + {digits before dot, or negative digits after dot in case of 0.0000n} + Digits := 0; + + {skip leading spaces} + while SChar(I) = ' ' do + inc(I); + + {get sign if any} + case SChar(I) of + '+' : + {skip +} + inc(I); + '-' : + begin + {negative number} + Sign := SignBit; + inc(I); + end; + end; + + {handle first digit} + if SChar(I) <> {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator then begin + if not IsDigit(SChar(I)) then + RaiseBcdError(stscBcdBadFormat); + + {skip leading zeros} + while SChar(I) = '0' do + inc(I); + + {add significant digits} + while IsDigit(SChar(I)) do begin + AddDigit(SChar(I)); + inc(I); + inc(Digits); + end; + end; + + {handle dot} + if SChar(I) = {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator then begin + inc(I); + if Digits = 0 then begin + {no digits before dot, skip zeros after dot} + while SChar(I) = '0' do begin + inc(I); + dec(Digits); + end; + end; + + {add significant digits} + while IsDigit(SChar(I)) do begin + AddDigit(SChar(I)); + inc(I); + end; + end; + + {handle exponent} + case SChar(I) of + 'e', 'E' : + begin + inc(I); + ExpSigned := False; + case SChar(I) of + '+' : + {skip +} + inc(I); + '-' : + begin + {negative exponent} + ExpSigned := True; + inc(I); + end; + end; + if not IsDigit(SChar(I)) then + {digit must follow 'e', invalid format} + RaiseBcdError(stscBcdBadFormat); + + {collect exponent value} + while IsDigit(SChar(I)) do begin + Exponent := 10*Exponent+Byte(SChar(I))-Byte('0'); + inc(I); + end; + + if ExpSigned then + Exponent := -Exponent; + end; + end; + + if SChar(I) <> #0 then + {should be end of string, otherwise invalid format} + RaiseBcdError(stscBcdBadFormat); + + {compute final exponent} + Inc(Exponent, Digits+ExpBias); + + if Exponent > NoSignBit then + {numeric overflow} + RaiseBcdError(stscBcdOverflow); + + if (Exponent <= 0) or IsZeroMantissa(UB) then + {return zero} + Exponent := 0; + + {Return packed result} + Pack(UB, Exponent, Sign, Result); +end; + +function FloatFormBcd(const Mask : string; B : TBCD; + const LtCurr, RtCurr : string; + Sep, DecPt : Char) : string; + {-Returns a formatted string with digits from B merged into the Mask} +const + Blank = 0; + Asterisk = 1; + Zero = 2; +const + FormChars : string = '#@*$-+,.'; + PlusArray : array[Boolean] of Char = ('+', '-'); + MinusArray : array[Boolean] of Char = (' ', '-'); + FillArray : array[Blank..Zero] of Char = (' ', '*', '0'); +var + ExpB : Byte absolute B; {B's sign/exponent byte} + S : string; {temporary string} + Filler : integer; {char for unused digit slots: ' ', '*', '0'} + WontFit, {true if number won't fit in the mask} + AddMinus, {true if minus sign needs to be added} + Dollar, {true if floating dollar sign is desired} + Negative : Boolean; {true if B is negative} + StartF, {starting point of the numeric field} + EndF : Word; {end of numeric field} + RtChars, {# of chars to add to right} + LtChars, {# of chars to add to left} + DotPos, {position of '.' in Mask} + Digits, {total # of digits} + Places, {# of digits after the '.'} + Blanks, {# of blanks returned by StrBcd} + FirstDigit, {pos. of first digit returned by Str} + Extras, {# of extra digits needed for special cases} + DigitPtr : Byte; {pointer into temporary string of digits} + I : Word; +label + EndFound, + RedoCase, + Done; +begin + Result := Mask; + + RtChars := 0; + LtChars := 0; + + {check for empty string} + if Length(Mask) = 0 then + goto Done; + + {initialize variables} + Filler := Blank; + DotPos := 0; + Places := 0; + Digits := 0; + Dollar := False; + AddMinus := True; + StartF := 1; + + {store the sign of the real and make it positive} + Negative := (ExpB and $80) <> 0; + ExpB := ExpB and $7F; + + {strip and count c's} + for I := Length(Result) downto 1 do begin + if Result[I] = 'C' then begin + Inc(RtChars); + System.Delete(Result, I, 1); + end else if Result[I] = 'c' then begin + Inc(LtChars); + System.Delete(Result, I, 1); + end; + end; + + {find the starting point for the field} + while (StartF <= Length(Result)) and + not CharExistsL(FormChars, Result[StartF]) do + Inc(StartF); + if StartF > Length(Mask) then + goto Done; + + {find the end point for the field} + EndF := StartF; + for I := StartF to Length(Result) do + begin + case Result[I] of + '*' : Filler := Asterisk; + '@' : Filler := Zero; + '$' : Dollar := True; + '-', + '+' : AddMinus := False; + '#' : {ignore} ; + ',', + '.' : DotPos := I; + else + goto EndFound; + end; + Inc(EndF); + end; + + {if we get here at all, the last char was part of the field} + Inc(EndF); + +EndFound: + {if we jumped to here instead, it wasn't} + Dec(EndF); + + {disallow Dollar if Filler is Zero} + if Filler = Zero then + Dollar := False; + + {we need an extra slot if Dollar is True} + Extras := Ord(Dollar); + + {get total # of digits and # after the decimal point} + if EndF > Length(Result) then {!!.02} + EndF := Length(Result); {!!.02} + + for I := StartF to EndF do + case Result[I] of + '#', '@', + '*', '$' : + begin + Inc(Digits); + if (I > DotPos) and (DotPos <> 0) then + Inc(Places); + end; + end; + + {need one more 'digit' if Places > 0} + Inc(Digits, Ord(Places > 0)); + +{also need an extra blank if (1) Negative is true, and (2) Filler is Blank, + and (3) AddMinus is true} + if Negative and AddMinus and (Filler = Blank) then + Inc(Extras) + else + AddMinus := False; + + {translate the BCD to a string} + S := StrBCD(B, Digits, Places); + + + {count number of initial blanks} + Blanks := 1; + while S[Blanks] = ' ' do + Inc(Blanks); + FirstDigit := Blanks; + Dec(Blanks); + +{the number won't fit if (a) S is longer than Digits or (b) the number of + initial blanks is less than Extras} + WontFit := (Length(S) > Digits) or (Blanks < Extras); + + {if it won't fit, fill decimal slots with '*'} + if WontFit then begin + for I := StartF to EndF do + case Result[I] of + '#', '@', '*', '$' : Result[I] := '*'; + '+' : Result[I] := PlusArray[Negative]; + '-' : Result[I] := MinusArray[Negative]; + end; + goto Done; + end; + + {fill initial blanks in S with Filler; insert floating dollar sign} + if Blanks > 0 then begin + StrPCopy(PChar(S), StringOfChar(FillArray[Filler], Blanks)); // FillChar(S[1], Blanks, FillArray[Filler]); + + {put floating dollar sign in last blank slot if necessary} + if Dollar then begin + S[Blanks] := LtCurr[1]; + Dec(Blanks); + end; + + {insert a minus sign if necessary} + if AddMinus then + S[Blanks] := '-'; + end; + + {put in the digits / signs} + DigitPtr := Length(S); + for I := EndF downto StartF do begin +RedoCase: + case Result[I] of + '#', '@', '*', '$' : + if DigitPtr <> 0 then begin + Result[I] := S[DigitPtr]; + Dec(DigitPtr); + if (DigitPtr <> 0) and (S[DigitPtr] = '.') then {!!.02} +// if (S[DigitPtr] = '.') and (DigitPtr <> 0) then + Dec(DigitPtr); + end + else + Result[I] := FillArray[Filler]; + ',' : begin + Result[I] := Sep; + if (I < DotPos) and (DigitPtr < FirstDigit) then begin + Result[I] := '#'; + goto RedoCase; + end; + end; + '.' : begin + Result[I] := DecPt; + if (I < DotPos) and (DigitPtr < FirstDigit) then begin + Result[I] := '#'; + goto RedoCase; + end; + end; + '+' : Result[I] := PlusArray[Negative]; + '-' : Result[I] := MinusArray[Negative]; + end; + end; + +Done: + if RtChars > 0 then begin + S := RtCurr; + if Length(S) > RtChars then + SetLength(S, RtChars) + else + S := LeftPadL(S, RtChars); + Result := Result + S; + end; + + if LtChars > 0 then begin + S := LtCurr; + if Length(S) > LtChars then + SetLength(S, LtChars) + else + S := PadL(S, LtChars); + Result := S + Result; + end; + +end; + +{routines to support C++Builder} +{$IFDEF CBuilder} +procedure AddBcd_C(const B1, B2 : TBcd; var Res : TBcd); +begin + Res := AddBcd(B1, B2); +end; + +procedure SubBcd_C(const B1, B2 : TBcd; var Res : TBcd); +begin + Res := SubBcd(B1, B2); +end; + +procedure MulBcd_C(const B1, B2 : TBcd; var Res : TBcd); +begin + Res := MulBcd(B1, B2); +end; + +procedure DivBcd_C(const B1, B2 : TBcd; var Res : TBcd); +begin + Res := DivBcd(B1, B2); +end; + +procedure ModBcd_C(const B1, B2 : TBcd; var Res : TBcd); +begin + Res := ModBcd(B1, B2); +end; + +procedure NegBcd_C(const B : TBcd; var Res : TBcd); +begin + Res := NegBcd(B); +end; + +procedure AbsBcd_C(const B : TBcd; var Res : TBcd); +begin + Res := AbsBcd(B); +end; + +procedure FracBcd_C(const B : TBcd; var Res : TBcd); +begin + Res := FracBcd(B); +end; + +procedure IntBcd_C(const B : TBcd; var Res : TBcd); +begin + Res := IntBcd(B); +end; + +procedure RoundDigitsBcd_C(const B : TBcd; Digits : Cardinal; var Res : TBcd); +begin + Res := RoundDigitsBcd(B, Digits); +end; + +procedure RoundPlacesBcd_C(const B : TBcd; Places : Cardinal; var Res : TBcd); +begin + Res := RoundPlacesBcd(B, Places); +end; + +procedure ValBcd_C(const S : string; var Res : TBcd); +begin + Res := ValBcd(S); +end; + +procedure LongBcd_C(L : LongInt; var Res : TBcd); +begin + Res := LongBcd(L); +end; + +procedure ExtBcd_C(E : Extended; var Res : TBcd); +begin + Res := ExtBcd(E); +end; + +procedure ExpBcd_C(const B : TBcd; var Res : TBcd); +begin + Res := ExpBcd(B); +end; + +procedure LnBcd_C(const B : TBcd; var Res : TBcd); +begin + Res := LnBcd(B); +end; + +procedure IntPowBcd_C(const B : TBcd; E : LongInt; var Res : TBcd); +begin + Res := IntPowBcd(B, E); +end; + +procedure PowBcd_C(const B, E : TBcd; var Res : TBcd); +begin + Res := PowBcd(B, E); +end; + +procedure SqrtBcd_C(const B : TBcd; var Res : TBcd); +begin + Res := SqrtBcd(B); +end; +{$ENDIF} + +initialization + ZeroBcd := FastVal('0.0'); + MinBcd := ValBcd('-9'+{$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator+'9E+63'); + BadBcd := MinBcd; + MaxBcd := ValBcd('9'+{$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator+'9E+63'); + PiBcd := FastVal('3.1415926535897932384626433832795028841971'); + Ln10Bcd := FastVal('2.3025850929940456840179914546843642076011'); + eBcd := FastVal('2.7182818284590452353602874713526624977572'); +end. diff --git a/components/systools/source/run/stlarr.pas b/components/systools/source/run/stlarr.pas new file mode 100644 index 000000000..61e4de8ca --- /dev/null +++ b/components/systools/source/run/stlarr.pas @@ -0,0 +1,1463 @@ +// 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: StLArr.pas 4.04 *} +{*********************************************************} +{* SysTools: Large array classes *} +{*********************************************************} + +{$IFDEF FPC} + {$mode DELPHI} +{$ENDIF} + +//{$I StDefine.inc} + +{Notes: + - requires a 386 or better processor, even for 16-bit Delphi apps + + - uses the value in the SYSTEM variable HeapAllocFlags when allocating + memory for the array. + + - changing the size of an array allocates a new array, transfers the + old data, and then frees the original array. + + - arrays are always indexed from 0 to Count-1. + + - after creating a descendant that knows the type of each element, an + indexed default property can be used to access array elements in a + convenient fashion, e.g., A[100] := 6.0; + + - the Get and Put methods don't perform range checking. + + - for 32-bit matrix, Rows*Cols cannot exceed 2**32. +} + +unit StLArr; + +interface + +uses + {$IFDEF FPC} + {$ELSE} + Windows, + {$ENDIF} + Classes, StConst, StBase; + +type + TStLArray = class(TStContainer) + {.Z+} + protected + {property instance variables} + FElSize : Integer; {Size of each array element} + FElStorable : boolean; {True if elements can be stored directly} + + {private instance variables} + laData : Pointer; {Pointer to data block} + + {undocumented protected 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 laSetCount(Elements : LongInt); + + {.Z-} + public + constructor Create(Elements : LongInt; ElementSize : Cardinal); + {-Initialize a large 1D array} + destructor Destroy; override; + {-Free a large 1D array} + + 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 Assign(Source: TPersistent); override; + {-Assign another container's contents to this one} + procedure Clear; override; + {-Fill the array with zeros} + + procedure Fill(const Value); + {-Fill array with specified value} + + procedure Put(El : LongInt; const Value); + {-Set an element} + procedure Get(El : LongInt; var Value); + {-Return an element} + + procedure Exchange(El1, El2 : LongInt); + {-Exchange the specified elements} + procedure Sort(Compare : TUntypedCompareFunc); + {-Sort the array using the given comparison function} + + property Count : LongInt + {-Read or write the number of elements in the array} + read FCount + write laSetCount; + + property ElementSize : Integer + read FElSize; + + property ElementsStorable : boolean + {-True if elements can be written directly to (or read from) disk} + read FElStorable write FElStorable; + end; + +type + TStLMatrix = class(TStContainer) + {.Z+} + protected + {property instance variables} + FElSize : Integer; {Size of each array element} + FCols : Cardinal; {Number of columns} + FRows : Cardinal; {Number of rows} + FElStorable : boolean; {True if elements can be stored directly} + + {private instance variables} + lmData : Pointer; {Pointer to data block} + lmRowSize : LongInt; {Number of bytes in a row} + + {undocumented protected 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 lmSetRows(Rows : Cardinal); + procedure lmSetCols(Cols : Cardinal); + + {.Z-} + public + constructor Create(Rows, Cols, ElementSize : Cardinal); + {-Initialize a large 2D matrix} + destructor Destroy; override; + {-Free a large 2D matrix} + + 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 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 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 lmSetRows; + property Cols : Cardinal + {-Read or write the number of columns in the array} + read FCols + write lmSetCols; + property ElementSize : Integer + read FElSize; + property ElementsStorable : boolean + {-True if elements can be written directly to (or read from) disk} + read FElStorable write FElStorable; + end; + +{======================================================================} + +implementation + +function AssignArrayData(Container : TStContainer; + var Data; + OtherData : Pointer) : Boolean; far; + var + OurArray : TStLArray absolute OtherData; + RD : TAssignRowData absolute Data; + begin + OurArray.Put(RD.RowNum, RD.Data); + Result := true; + end; + +function AssignMatrixData(Container : TStContainer; + var Data; + OtherData : Pointer) : Boolean; far; + var + OurMatrix : TStLMatrix absolute OtherData; + RD : TAssignRowData absolute Data; + begin + OurMatrix.PutRow(RD.RowNum, RD.Data); + Result := true; + end; + +procedure TStLArray.Assign(Source: TPersistent); + begin + {$IFDEF ThreadSafe} + EnterCS; + try + {$ENDIF} + {The only containers that we allow to be assigned to a large array + are: + - another SysTools large array (TStLArray) + - a SysTools large matrix (TStLMatrix) with one column + - a SysTools virtual matrix (TStVMatrix) with one column} + if not AssignUntypedVars(Source, AssignArrayData) then + inherited Assign(Source); + {$IFDEF ThreadSafe} + finally + LeaveCS; + end;{try..finally} + {$ENDIF} + end; + +procedure TStLArray.Clear; +var + C : LongInt; +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} + C := FCount; + HugeFillChar(laData^, C*FElSize, 0); +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLArray.ForEachUntypedVar(Action : TIterateUntypedFunc; + OtherData : pointer); + var + FullRow : ^TAssignRowData; + i : Cardinal; + begin + {$IFDEF ThreadSafe} + EnterCS; + try + {$ENDIF} + GetMem(FullRow, sizeof(Cardinal) + ElementSize); + try + for i := 0 to pred(Count) do + begin + FullRow^.RowNum := i; + Get(i, FullRow^.Data); + Action(Self, FullRow^, OtherData); + end; + finally + FreeMem(FullRow, sizeof(Cardinal) + ElementSize); + end; + {$IFDEF ThreadSafe} + finally + LeaveCS; + end; + {$ENDIF} + end; + +procedure TStLArray.GetArraySizes(var RowCount, ColCount, ElSize : Cardinal); +begin + RowCount := Count; + ColCount := 1; + ElSize := ElementSize; +end; + +procedure TStLArray.SetArraySizes(RowCount, ColCount, ElSize : Cardinal); +begin + if (ColCount <> 1) then + RaiseContainerError(stscTooManyCols); + if (LongInt(RowCount) <> Count) or + (LongInt(ElSize) <> ElementSize) then begin + HugeFreeMem(laData, FCount*FElSize); + FCount := RowCount; + FElSize := ElSize; + HugeGetMem(laData, RowCount*ElSize); + Clear; + end; +end; + +function TStLArray.StoresUntypedVars : boolean; +begin + Result := True; +end; + +constructor TStLArray.Create(Elements : LongInt; ElementSize : Cardinal); +begin + if (Elements <= 0) or (ElementSize = 0) or + ProductOverflow(Elements, ElementSize) then + RaiseContainerError(stscBadSize); + + CreateContainer(TStNode, 0); + + FCount := Elements; + FElSize := ElementSize; + + HugeGetMem(laData, Elements*LongInt(ElementSize)); + Clear; +end; + +destructor TStLArray.Destroy; +begin + HugeFreeMem(laData, FCount*FElSize); + IncNodeProtection; + inherited Destroy; +end; + +procedure TStLArray.Exchange(El1, El2 : LongInt); +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} +{$IFOPT R+} + if (El1 < 0) or (El1 >= Count) or (El2 < 0) or (El2 >= Count) then + RaiseContainerError(stscBadIndex); +{$ENDIF} + asm + mov eax,Self + push ebx + push esi + push edi + + mov esi,El1 + mov edi,El2 + mov ecx,TStLArray([eax]).FElSize + mov edx,TStLArray([eax]).laData + db $0F,$AF,$F1 {imul esi,ecx, compiler bug workaround} + add esi,edx + db $0F,$AF,$F9 {imul edi,ecx, compiler bug workaround} + add edi,edx + mov edx,ecx + shr ecx,2 + jz @2 + + @1: mov eax,[esi] {avoid xchg instruction, which is slow} + mov ebx,[edi] + mov [esi],ebx + mov [edi],eax + add esi,4 + add edi,4 + dec ecx + jnz @1 + + @2: mov ecx,edx + and ecx,3 + jz @4 + + @3: mov al,[esi] {avoid xchg instruction, which is slow} + mov bl,[edi] + mov [esi],bl + mov [edi],al + inc esi + inc edi + dec ecx + jnz @3 + + @4: pop edi + pop esi + pop ebx + end; +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + + +procedure TStLArray.Fill(const Value); +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} + HugeFillStruc(laData^, FCount, Value, FElSize); +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLArray.Get(El : LongInt; var Value); +(* model for code below +begin + move((PChar(laData)+El*FElSize)^, Value, FElSize); +end; +*) +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} +{$IFOPT R+} + if (El < 0) or (El >= Count) then + RaiseContainerError(stscBadIndex); +{$ENDIF} + asm + mov eax,Self + push esi + push edi + mov edi,Value + mov ecx,TStLArray([eax]).FElSize + mov esi,El + db $0F,$AF,$F1 {imul esi,ecx, compiler bug workaround} + add esi,TStLArray([eax]).laData + mov eax,ecx + shr ecx,2 + rep movsd + mov ecx,eax + and ecx,3 + rep movsb + pop edi + pop esi + end; +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + + +procedure TStLArray.laSetCount(Elements : LongInt); +var + CurSize, NewSize : LongInt; + CurFData : Pointer; +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} + {validate new size} + if (Elements <= 0) or ProductOverflow(Elements, FElSize) then + RaiseContainerError(stscBadSize); + + NewSize := Elements*FElSize; + CurSize := FCount*FElSize; + CurFData := laData; + + {allocate data block of new size} + HugeGetMem(laData, NewSize); + + FCount := Elements; + + {fill extra area with zeros and copy old data} + if NewSize > CurSize then begin + Clear; + NewSize := CurSize; + end; + HugeMove(CurFData^, laData^, NewSize); + + {free original data area} + HugeFreeMem(CurFData, CurSize); +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLArray.Put(El : LongInt; const Value); +(* model for assembly language below +begin + move(Value, (PChar(laData)+Row*FElSize)^, FElSize); +end; +*) +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} +{$IFOPT R+} + if (El < 0) or (El >= Count) then + RaiseContainerError(stscBadIndex); +{$ENDIF} + asm + mov eax,Self + push esi + push edi + mov esi,Value + mov ecx,TStLArray([eax]).FElSize + mov edi,El + db $0F,$AF,$F9 {imul edi,ecx, compiler bug workaround} + add edi,TStLArray([eax]).laData + mov eax,ecx + shr ecx,2 + rep movsd + mov ecx,eax + and ecx,3 + rep movsb + pop edi + pop esi + end; +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLArray.Sort(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} + {Need at least 2 elements to sort} + if FCount <= 1 then + Exit; + + GetMem(CurEl, FElSize); + try + GetMem(PivEl, FElSize); + try + {Initialize the stacks} + StackP := 0; + LStack[0] := 0; + RStack[0] := FCount-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, PivEl^); + PL := L; + PR := R; + + {Swap items in sort order around the pivot index} + repeat + Get(PL, CurEl^); + while Compare(CurEl^, PivEl^) < 0 do begin + Inc(PL); + Get(PL, CurEl^); + end; + Get(PR, CurEl^); + while Compare(PivEl^, CurEl^) < 0 do begin + Dec(PR); + Get(PR, CurEl^); + end; + if PL <= PR then begin + if PL <> PR then + {Swap the two elements} + Exchange(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; + finally + FreeMem(PivEl, FElSize); + end; + finally + FreeMem(CurEl, FElSize); + end; +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLArray.LoadFromStream(S : TStream); +var + Data : pointer; + Reader : TReader; + NumElements : longint; + ElementSize : LongInt; + i : longint; + TotSize : longint; + StreamedClass : TPersistentClass; + StreamedClassName : string; + Value : TValueType; +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(TStLArray, StreamedClass)) then + RaiseContainerError(stscWrongClass); + NumElements := ReadInteger; + ElementSize := ReadInteger; + if (NumElements <> FCount) or (ElementSize <> FElSize) then + begin + HugeFreeMem(laData, FCount*FElSize); + FCount := NumElements; + FElSize := ElementSize; + HugeGetMem(laData, NumElements*ElementSize); + Clear; + end; + ElementsStorable := ReadBoolean; + if ElementsStorable then + begin + Read(Value, sizeof(Value)); {s/b vaBinary} + Read(TotSize, sizeof(longint)); + GetMem(Data, FElSize); + try + for i := 0 to pred(FCount) do + begin + Read(Data^, FElSize); + Put(i, Data^); + end; + finally + FreeMem(Data, FElSize); + end; + end + else + begin + ReadListBegin; + for i := 0 to pred(FCount) do begin + Data := DoLoadData(Reader); + Put(i, Data^); + end; + ReadListEnd; + end; + end; + finally + Reader.Free; + end; +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLArray.StoreToStream(S : TStream); +var + Writer : TWriter; + i : integer; + Data : pointer; + TotSize: longint; + Value : TValueType; +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} + Writer := TWriter.Create(S, 1024); + try + GetMem(Data, FElSize); + try + with Writer do begin + WriteString(Self.ClassName); + WriteInteger(FCount); + WriteInteger(FElSize); + WriteBoolean(FElStorable); + if ElementsStorable then begin + Value := vaBinary; + Write(Value, sizeof(Value)); + TotSize := FCount * FElSize; + Write(TotSize, sizeof(longint)); + for i := 0 to pred(FCount) do begin + Get(i, Data^); + Write(Data^, FElSize); + end; + end else begin + WriteListBegin; + for i := 0 to pred(FCount) do begin + Get(i, Data^); + DoStoreData(Writer, Data); + end; + WriteListEnd; + end; + end; + finally + FreeMem(Data, FElSize); + end; + finally + Writer.Free; + end; +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +{----------------------------------------------------------------------} + +procedure TStLMatrix.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) + - another SysTools large matrix (TStLMatrix) + - a SysTools virtual matrix (TStVMatrix)} + if not AssignUntypedVars(Source, AssignMatrixData) then + inherited Assign(Source); + {$IFDEF ThreadSafe} + finally + LeaveCS; + end;{try..finally} + {$ENDIF} + end; + +procedure TStLMatrix.Clear; +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} + HugeFillChar(lmData^, FCount*FElSize, 0); +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLMatrix.ForEachUntypedVar(Action : TIterateUntypedFunc; + OtherData : pointer); + var + FullRow : ^TAssignRowData; + i : Cardinal; + begin + {$IFDEF ThreadSafe} + EnterCS; + try + {$ENDIF} + GetMem(FullRow, sizeof(Cardinal) + lmRowSize); + 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) + lmRowSize); + end; + {$IFDEF ThreadSafe} + finally + LeaveCS; + end; + {$ENDIF} + end; + +procedure TStLMatrix.GetArraySizes(var RowCount, ColCount, ElSize : Cardinal); +begin + RowCount := Rows; + ColCount := Cols; + ElSize := ElementSize; +end; + +procedure TStLMatrix.SetArraySizes(RowCount, ColCount, ElSize : Cardinal); +begin + if (RowCount <> Rows) or (ColCount <> Cols) or + (LongInt(ElSize) <> ElementSize) then + begin + HugeFreeMem(lmData, FCount*FElSize); + FElSize := ElSize; + FRows := RowCount; + FCols := ColCount; + {$IFDEF VERSION4} + FCount := RowCount*ColCount; + lmRowSize := ColCount*ElSize; + HugeGetMem(lmData, FCount*LongInt(ElSize)); + {$ELSE} + FCount := LongInt(RowCount)*ColCount; + lmRowSize := LongInt(ColCount)*ElSize; + HugeGetMem(lmData, FCount*ElSize); + {$ENDIF} + Clear; + end; +end; + +function TStLMatrix.StoresUntypedVars : boolean; +begin + Result := true; +end; + +constructor TStLMatrix.Create(Rows, Cols, ElementSize : Cardinal); +begin + CreateContainer(TStNode, 0); + + FElSize := ElementSize; + FRows := Rows; + FCols := Cols; + FCount := LongInt(Rows)*LongInt(Cols); + lmRowSize := LongInt(Cols)*LongInt(ElementSize); + + if (Rows = 0) or (Cols = 0) or (ElementSize = 0) or + ProductOverflow(FCount, ElementSize) then + RaiseContainerError(stscBadSize); + + HugeGetMem(lmData, FCount*LongInt(ElementSize)); + Clear; +end; + +destructor TStLMatrix.Destroy; +begin + HugeFreeMem(lmData, FCount*FElSize); + IncNodeProtection; + inherited Destroy; +end; + +procedure TStLMatrix.ExchangeRows(Row1, Row2 : Cardinal); +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} +{$IFOPT R+} + if (Row1 >= Rows) or (Row2 >= Rows) then + RaiseContainerError(stscBadIndex); +{$ENDIF} + asm + mov eax,Self + push ebx + push esi + push edi + + mov esi,Row1 + mov edi,Row2 + mov ecx,TStLMatrix([eax]).lmRowSize + mov edx,TStLMatrix([eax]).lmData + db $0F,$AF,$F1 {imul esi,ecx, compiler bug workaround} + add esi,edx + db $0F,$AF,$F9 {imul edi,ecx, compiler bug workaround} + add edi,edx + mov edx,ecx + shr ecx,2 + jz @2 + + @1: mov eax,[esi] {avoid xchg instruction, which is slow} + mov ebx,[edi] + mov [esi],ebx + mov [edi],eax + add esi,4 + add edi,4 + dec ecx + jnz @1 + + @2: mov ecx,edx + and ecx,3 + jz @4 + + @3: mov al,[esi] {avoid xchg instruction, which is slow} + mov bl,[edi] + mov [esi],bl + mov [edi],al + inc esi + inc edi + dec ecx + jnz @3 + + @4: pop edi + pop esi + pop ebx + end; +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLMatrix.Fill(const Value); +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} + HugeFillStruc(lmData^, FCount, Value, FElSize); +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLMatrix.Get(Row, Col : Cardinal; var Value); +(* model for assembly language below +begin + move((PChar(lmData)+(Row*FCols+Col)*FElSize)^, Value, FElSize); +end; +*) +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} + if (Row >= Rows) or (Col >= Cols) then + RaiseContainerError(stscBadIndex); + asm + mov eax,Self + push esi + push edi + mov edi,Value + mov esi,Row + imul esi,TStLMatrix([eax]).FCols + add esi,Col + mov ecx,TStLMatrix([eax]).FElSize + db $0F,$AF,$F1 {imul esi,ecx, compiler bug workaround} + add esi,TStLMatrix([eax]).lmData + mov eax,ecx + shr ecx,2 + rep movsd + mov ecx,eax + and ecx,3 + rep movsb + pop edi + pop esi + end; +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLMatrix.GetRow(Row : Cardinal; var RowValue); +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} +{$IFOPT R+} + if Row >= Rows then + RaiseContainerError(stscBadIndex); +{$ENDIF} + move((PAnsiChar(lmData)+(LongInt(Row)*lmRowSize))^, RowValue, lmRowSize); +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLMatrix.lmSetCols(Cols : Cardinal); +var + CurSize, NewSize, CurRowSize, NewRowSize, BufSize : LongInt; + R, CurCols : Cardinal; + CurFData, NewFData, RowData : Pointer; +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} + if Cols = FCols then + Exit; + + {validate new size} + if (Cols = 0) or + ProductOverflow(Cols, FRows) or + ProductOverflow(LongInt(Cols)*LongInt(FRows), FElSize) then + RaiseContainerError(stscBadSize); + + {compute and save various sizes} + CurSize := FCount*FElSize; + NewSize := LongInt(Cols)*LongInt(FRows)*FElSize; + CurRowSize := lmRowSize; + NewRowSize := LongInt(Cols)*FElSize; + CurCols := FCols; + CurFData := lmData; + + {allocate data block of new size} + HugeGetMem(NewFData, NewSize); + + {allocate a buffer to transfer row data} + if NewRowSize > CurRowSize then + BufSize := NewRowSize + else + BufSize := CurRowSize; + try + HugeGetMem(RowData, BufSize); + except + HugeFreeMem(NewFData, NewSize); + end; + + {transfer rows from old array to new} + if Cols > CurCols then + HugeFillChar(RowData^, BufSize, 0); + for R := 0 to FRows-1 do begin + FCols := CurCols; + lmRowSize := CurRowSize; + lmData := CurFData; + GetRow(R, RowData^); + FCols := Cols; + lmRowSize := NewRowSize; + lmData := NewFData; + PutRow(R, RowData^); + end; + HugeFreeMem(RowData, BufSize); + + FCount := LongInt(Cols)*LongInt(FRows); + + {free original data area} + HugeFreeMem(CurFData, CurSize); +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLMatrix.lmSetRows(Rows : Cardinal); +var + CurSize, NewSize : LongInt; + CurFData : Pointer; +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} + if Rows = FRows then + Exit; + + {validate new size} + if (Rows = 0) or + ProductOverflow(Rows, FCols) or + ProductOverflow(LongInt(Rows)*LongInt(FCols), FElSize) then + RaiseContainerError(stscBadSize); + + CurSize := FCount*FElSize; + NewSize := LongInt(Rows)*LongInt(FCols)*FElSize; + CurFData := lmData; + + {allocate data block of new size} + HugeGetMem(lmData, NewSize); + + FCount := LongInt(Rows)*LongInt(FCols); + FRows := Rows; + + {fill extra area with zeros and copy old data} + if NewSize > CurSize then begin + Clear; + NewSize := CurSize; + end; + HugeMove(CurFData^, lmData^, NewSize); + + {free original data area} + HugeFreeMem(CurFData, CurSize); +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLMatrix.Put(Row, Col : Cardinal; const Value); +(* model for assembly language below +begin + move(Value, (PChar(lmData)+(Row*FCols+Col)*FElSize)^, FElSize); +end; +*) +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} +{$IFOPT R+} + if (Row >= Rows) or (Col >= Cols) then + RaiseContainerError(stscBadIndex); +{$ENDIF} + asm + mov eax,Self + push esi + push edi + mov esi,Value + mov edi,Row + imul edi, TStLMatrix([eax]).FCols + add edi,Col + mov ecx,TStLMatrix([eax]).FElSize + db $0F,$AF,$F9 {imul edi,ecx, compiler bug workaround} + add edi,TStLMatrix([eax]).lmData + mov eax,ecx + shr ecx,2 + rep movsd + mov ecx,eax + and ecx,3 + rep movsb + pop edi + pop esi + end; +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLMatrix.PutRow(Row : Cardinal; const RowValue); +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} +{$IFOPT R+} + if Row >= Rows then + RaiseContainerError(stscBadIndex); +{$ENDIF} + move(RowValue, (PAnsiChar(lmData)+(LongInt(Row)*lmRowSize))^, lmRowSize); +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLMatrix.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 >= FCols 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 TStLMatrix.LoadFromStream(S : TStream); +var + Data : pointer; + Reader : TReader; + NumRows : longint; + NumCols : longint; + ElementSize : cardinal; + R, C : longint; + TotSize : longint; + StreamedClass : TPersistentClass; + StreamedClassName : string; + Value : TValueType; +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(TStLMatrix, StreamedClass)) then + RaiseContainerError(stscWrongClass); + NumRows := ReadInteger; + NumCols := ReadInteger; + ElementSize := ReadInteger; + if (NumRows <> LongInt(Rows)) or (NumCols <> LongInt(Cols)) or + (LongInt(ElementSize) <> FElSize) then + begin + HugeFreeMem(lmData, FCount*FElSize); + FElSize := ElementSize; + FRows := NumRows; + FCols := NumCols; + FCount := LongInt(NumRows)*NumCols; + lmRowSize := LongInt(NumCols)*LongInt(ElementSize); + HugeGetMem(lmData, FCount*LongInt(ElementSize)); + Clear; + end; + ElementsStorable := ReadBoolean; + if ElementsStorable then + begin + Read(Value, sizeof(Value)); {s/b vaBinary} + Read(TotSize, sizeof(longint)); + GetMem(Data, FElSize); + try + for R := 0 to pred(FRows) do + for C := 0 to pred(FCols) do + begin + Read(Data^, FElSize); + Put(R, C, Data^); + end; + finally + FreeMem(Data, FElSize); + end; + end + else + begin + ReadListBegin; + for R := 0 to pred(FRows) do + for C := 0 to pred(FCols) do begin + Data := DoLoadData(Reader); + Put(R, C, Data^); + end; + ReadListEnd; + end; + end; + finally + Reader.Free; + end; +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + +procedure TStLMatrix.StoreToStream(S : TStream); +var + Writer : TWriter; + R, C : integer; + Data : pointer; + TotSize: longint; + Value : TValueType; +begin +{$IFDEF ThreadSafe} + EnterCS; + try +{$ENDIF} + Writer := TWriter.Create(S, 1024); + try + GetMem(Data, FElSize); + try + with Writer do + begin + WriteString(Self.ClassName); + WriteInteger(FRows); + WriteInteger(FCols); + WriteInteger(FElSize); + WriteBoolean(FElStorable); + if ElementsStorable then + begin + Value := vaBinary; + Write(Value, sizeof(Value)); + TotSize := FCount * FElSize; + Write(TotSize, sizeof(longint)); + for R := 0 to pred(FRows) do + for C := 0 to pred(FCols) do + begin + Get(R, C, Data^); + Write(Data^, FElSize); + end; + end + else + begin + WriteListBegin; + for R := 0 to pred(FRows) do + for C := 0 to pred(FCols) do + begin + Get(R, C, Data^); + DoStoreData(Writer, Data); + end; + WriteListEnd; + end; + end; + finally + FreeMem(Data, FElSize); + end; + finally + Writer.Free; + end; +{$IFDEF ThreadSafe} + finally + LeaveCS; + end; +{$ENDIF} +end; + + +end.