fpspreadsheet: Avoid Banker's rounding (https://forum.lazarus.freepascal.org/index.php/topic,46104.0.html). Add unit tests for it.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7061 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/fpspreadsheet/source/common/fpsfunc.pas

@@ -408,6 +408,15 @@ begin
   Result := FloatResult(random);
 end;
 
+// Avoids Banker's rounding
+function MyRoundTo(const AValue: Double; const Digits: TRoundToRange): Double;
+var
+  RV: Double;
+begin
+  RV := IntPower(10,Digits);
+  Result := fpsUtils.Round(AValue / RV) * RV;
+end;
+
 procedure fpsROUND(var Result: TsExpressionResult; const Args: TsExprParameterArray);
 var
   x: TsExprFloat;
@@ -422,7 +431,7 @@ begin
     if IsNaN(x) then
       Result := ErrorResult(errWrongType)
     else
-      Result := FloatResult(RoundTo(x, -n));
+      Result := FloatResult(MyRoundTo(x, -n));
       // -n because fpc and Excel have different conventions regarding the sign
   end;
 end;

components/fpspreadsheet/source/common/fpsnumformat.pas

@@ -859,8 +859,9 @@ begin
 
   // No decimal separator --> format as integer
   if i >= numEl then begin
-    Result := ProcessIntegerFormat(IntToStr(round(AValue)), fs, AElements, AIndex,
-      (INT_TOKENS + [nftIntTh]), false, useThSep);
+    // fpsUtils.Round() avoids Banker's rounding
+    Result := ProcessIntegerFormat(IntToStr(fpsUtils.Round(AValue)), fs,
+      AElements, AIndex, (INT_TOKENS + [nftIntTh]), false, useThSep);
     exit;
   end;
 

components/fpspreadsheet/source/common/fpsutils.pas

@@ -153,6 +153,8 @@ function TryStrToFloatAuto(AText: String; out ANumber: Double;
 function TryFractionStrToFloat(AText: String; out ANumber: Double;
   out AIsMixed: Boolean; out AMaxDigits: Integer): Boolean;
 
+function Round(AValue: Double): Integer;
+
 function cmToPts(AValue: Double): Double; inline;
 function EMUToIn(AValue: Int64): Double; inline;
 function EMUToMM(AValue: Int64): Double; inline;
@@ -1849,6 +1851,16 @@ begin
   Result := true;
 end;
 
+{@@ ----------------------------------------------------------------------------
+  Special rounding function which avoids banker's rounding
+-------------------------------------------------------------------------------}
+function Round(AValue: Double): Integer;
+begin
+  if AValue > 0 then
+    Result := trunc(AValue + 0.5)
+  else
+    Result := trunc(AValue - 0.5);
+end;
 
 {@@ ----------------------------------------------------------------------------
   Excel's unit of row heights is "twips", i.e. 1/20 point.

components/fpspreadsheet/tests/mathtests.pas

@@ -0,0 +1,87 @@
+{-------------------------------------------------------------------------------
+   Tests for some dedicated math routines which are specific to spreadsheets.
+-------------------------------------------------------------------------------}
+
+unit mathtests;
+
+{$mode objfpc}{$H+}
+{$modeswitch advancedrecords}
+
+interface
+
+uses
+  {$IFDEF Unix}
+  //required for formatsettings
+  clocale,
+  {$ENDIF}
+  // Not using Lazarus package as the user may be working with multiple versions
+  // Instead, add .. to unit search path
+  Classes, SysUtils, fpcunit, testutils, testregistry, testsutility,
+  fpstypes, fpspreadsheet, fpsutils;
+
+type
+  { TSpreadMathTests }
+  //Write to xls/xml file and read back
+  TSpreadMathTests = class(TTestCase)
+  private
+  protected
+    procedure TestRound(InputValue: Double; Expected: Integer);
+
+  published
+    // Test whether "round" avoids Banker's rounding
+    procedure TestRound_plus15;
+    procedure Testround_minus15;
+    procedure TestRound_plus25;
+    procedure TestRound_minus25;
+
+  end;
+
+implementation
+
+{ TSpreadMathTests }
+
+procedure TSpreadMathTests.TestRound(InputValue: Double; Expected: Integer);
+var
+  book: TsWorkbook;
+  sheet: TsWorksheet;
+  readValue: String;
+begin
+  book := TsWorkbook.Create;
+  try
+    sheet := book.AddWorksheet('Math');
+    sheet.WriteNumber(1, 1, InputValue, nfFixed, 0);
+    readValue := sheet.ReadAsText(1, 1);
+
+    CheckEquals(Expected, StrToInt(readValue),
+      'Rounding error, sheet "' + sheet.Name + '"')
+  finally
+    book.Free;
+  end;
+end;
+
+procedure TSpreadMathTests.TestRound_plus15;
+begin
+  TestRound(1.5, 2);
+end;
+
+procedure TSpreadMathTests.TestRound_minus15;
+begin
+  Testround(-1.5, -2);
+end;
+
+procedure TSpreadMathTests.TestRound_plus25;
+begin
+  TestRound(2.5, 3);
+end;
+
+procedure TSpreadMathTests.Testround_minus25;
+begin
+  TestRound(-2.5, -3);
+end;
+
+
+initialization
+  RegisterTest(TSpreadMathTests);
+
+end.
+

components/fpspreadsheet/tests/spreadtestgui.lpi

@@ -40,7 +40,7 @@
         <PackageName Value="FCL"/>
       </Item4>
     </RequiredPackages>
-    <Units Count="31">
+    <Units Count="32">
       <Unit0>
         <Filename Value="spreadtestgui.lpr"/>
         <IsPartOfProject Value="True"/>
@@ -167,6 +167,10 @@
         <Filename Value="fileformattests.pas"/>
         <IsPartOfProject Value="True"/>
       </Unit30>
+      <Unit31>
+        <Filename Value="mathtests.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit31>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

components/fpspreadsheet/tests/spreadtestgui.lpr

@@ -9,7 +9,7 @@ uses
   SysUtils,
  {$ENDIF}
   Interfaces, Forms, GuiTestRunner, testsutility,
-  datetests, stringtests, numberstests, manualtests, internaltests,
+  datetests, stringtests, numberstests, manualtests, internaltests, mathtests,
   fileformattests, formattests, colortests, fonttests, optiontests,
   numformatparsertests, formulatests, rpnFormulaUnit, singleformulatests,
   exceltests, emptycelltests, errortests, virtualmodetests,