pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

fpspreadsheet: Fix compilation error introduced yesterday. Fix multi-key sorting which now passes all tests.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3679 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2014-10-23 09:07:20 +00:00
parent 4a1a99044b
commit fb8faab20b
6 changed files with 90 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
components/fpspreadsheet/examples/other/demo_sorting.lpi
View File

@ -45,7 +45,6 @@
<Unit1>
<Filename Value="..\..\fpsexprparser.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpsExprParser"/>
</Unit1>
</Units>
</ProjectOptions>

4
components/fpspreadsheet/fpsexprparser.pas
View File

@ -833,7 +833,7 @@ const
implementation
uses
typinfo, math, lazutf8, dateutils, fpsutils; //, fpsfunc;
typinfo, math, lazutf8, dateutils, fpsutils, fpsfunc;
const
cNull = #0;
@ -4258,7 +4258,7 @@ initialization
ExprFormatSettings.DecimalSeparator := '.';
ExprFormatSettings.ListSeparator := ',';
// RegisterStdBuiltins(BuiltinIdentifiers);
RegisterStdBuiltins(BuiltinIdentifiers);
finalization
FreeBuiltins;

12
components/fpspreadsheet/fpsfunc.pas
View File

@ -9,15 +9,15 @@ unit fpsfunc;
interface
uses
Classes, SysUtils, fpspreadsheet, fpsexprparser;
Classes, SysUtils, fpspreadsheet;
procedure RegisterStdBuiltins(AManager : TsBuiltInExpressionManager);
procedure RegisterStdBuiltins(AManager: TComponent); //TsBuiltInExpressionManager);
implementation
uses
Math, lazutf8, StrUtils, DateUtils, xlsconst, fpsUtils;
Math, lazutf8, StrUtils, DateUtils, xlsconst, fpsUtils, fpsexprparser;
{------------------------------------------------------------------------------}
@ -1529,11 +1529,11 @@ end;
{------------------------------------------------------------------------------}
{@@ Registers the standard built-in functions. Called automatically. }
procedure RegisterStdBuiltins(AManager : TsBuiltInExpressionManager);
procedure RegisterStdBuiltins(AManager : TComponent);
var
cat: TsBuiltInExprCategory;
begin
with AManager do
with AManager as TsBuiltInExpressionManager do
begin
// Math functions
cat := bcMath;
@ -1891,7 +1891,5 @@ end;
*)
initialization
RegisterStdBuiltins(BuiltinIdentifiers);
end.

81
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -542,7 +542,10 @@ type
procedure RemoveAndFreeCell(ARow, ACol: Cardinal);
// Sorting
function DoCompareCells(ACell1, ACell2: PCell; ASortOrder: TsSortOrder): Integer;
function DoCompareCells(ARow1, ACol1, ARow2, ACol2: Cardinal;
ASortOrder: TsSortOrder): Integer;
function DoInternalCompareCells(ACell1, ACell2: PCell;
ASortOrder: TsSortOrder): Integer;
procedure DoExchangeColRow(AIsColumn: Boolean; AIndex, WithIndex: Cardinal;
AFromIndex, AToIndex: Cardinal);
@ -3198,7 +3201,50 @@ begin
end;
{@@ ----------------------------------------------------------------------------
Compare function for sorting of rows and columns
Compare function for sorting of rows and columns called directly by Sort()
The compare algorithm starts with the first key parameters. If cells are
found to be "equal" the next parameter is set is used until a difference is
found, or all parameters are used.
@param ARow1 Row index of the first cell to be compared
@param ACol1 Column index of the first cell to be compared
@param ARow2 Row index of the second cell to be compared
@parem ACol2 Column index of the second cell to be compared
@return -1 if the first cell is "smaller", i.e. is sorted in front of the
second one
+1 if the first cell is "larger", i.e. is behind the second one
0 if both cells are equal
------------------------------------------------------------------------------- }
function TsWorksheet.DoCompareCells(ARow1, ACol1, ARow2, ACol2: Cardinal;
ASortOrder: TsSortOrder): Integer;
var
cell1, cell2: PCell; // Pointers to the cells to be compared
key: Integer;
begin
cell1 := FindCell(ARow1, ACol1);
cell2 := FindCell(ARow2, ACol2);
Result := DoInternalCompareCells(cell1, cell2, ASortOrder);
if Result = 0 then begin
key := 1;
while (Result = 0) and (key <= High(FSortParams.Keys)) do
begin
if FSortParams.SortByCols then
begin
cell1 := FindCell(ARow1, FSortParams.Keys[key].ColRowIndex);
cell2 := FindCell(ARow2, FSortParams.Keys[key].ColRowIndex);
end else
begin
cell1 := FindCell(FSortParams.Keys[key].ColRowIndex, ACol1);
cell2 := FindCell(FSortParams.Keys[key].ColRowIndex, ACol2);
end;
Result := DoInternalCompareCells(cell1, cell2, ASortOrder);
inc(key);
end;
end;
end;
{@@ ----------------------------------------------------------------------------
Compare function for sorting of rows and columns. Called by DoCompareCells.
@param ACell1 Pointer to the first cell of the comparison
@param ACell2 Pointer to the second cell of the comparison
@ -3209,14 +3255,14 @@ end;
Date/time and boolean cells are sorted like number cells according
to their number value
Label cells are sorted like UTF8 strings.
Label cells are sorted as UTF8 strings.
In case of mixed cell content types the order is determined by
the parameter Priority of the SortParams.
Empty cells are always at the end (in both ascending and descending
order)
-------------------------------------------------------------------------------}
function TsWorksheet.DoCompareCells(ACell1, ACell2: PCell;
function TsWorksheet.DoInternalCompareCells(ACell1, ACell2: PCell;
ASortOrder: TsSortOrder): Integer;
// Sort priority in Excel:
// numbers < alpha < blank (ascending)
@ -3335,14 +3381,31 @@ procedure TsWorksheet.Sort(const ASortParams: TsSortParams;
var
I,J,K: Integer;
P: Integer;
index: Integer;
order: TsSortOrder;
{
cell1, cell2: PCell;
compareResult: Integer;
}
begin
index := ASortParams.Keys[0].ColRowIndex; // less typing...
order := ASortParams.Keys[0].Order;
repeat
I := L;
J := R;
P := (L + R) div 2;
repeat
if ASortParams.SortByCols then
begin
while DoCompareCells(P, index, I, index, order) > 0 do inc(I);
while DoCompareCells(P, index, J, index, order) < 0 do dec(J);
end else
begin
while DoCompareCells(index, P, index, I, order) > 0 do inc(I);
while DoCompareCells(index, P, index, J, order) < 0 do dec(J);
end;
{ original code from "grids.pas":
if ColSorting then begin
@ -3352,7 +3415,7 @@ procedure TsWorksheet.Sort(const ASortParams: TsSortParams;
while DoCompareCells(P, index, I, index)>0 do I:=I+1;
while DoCompareCells(P, index, J, index)<0 do J:=J-1;
end; }
{
if ASortParams.SortByCols then
begin
(*
@ -3528,7 +3591,7 @@ procedure TsWorksheet.Sort(const ASortParams: TsSortParams;
end;
end;
*)
end;
end; }
if I <= J then
begin
@ -3536,15 +3599,21 @@ procedure TsWorksheet.Sort(const ASortParams: TsSortParams;
begin
if ASortParams.SortByCols then
begin
if DoCompareCells(I, index, J, index, order) <> 0 then
{
cell1 := FindCell(I, ASortParams.Keys[0].ColRowIndex);
cell2 := FIndCell(J, ASortParams.Keys[0].ColRowIndex);
if DoCompareCells(cell1, cell2, ASortParams.Keys[0].Order) <> 0 then
}
DoExchangeColRow(not ASortParams.SortByCols, J,I, AColFrom, AColTo);
end else
begin
if DoCompareCells(index, I, index, J, order) <> 0 then
{
cell1 := FindCell(ASortParams.Keys[0].ColRowIndex, I);
cell2 := FIndCell(ASortParams.Keys[0].ColRowIndex, J);
if DoCompareCells(cell1, cell2, ASortParams.Keys[0].Order) <> 0 then
}
DoExchangeColRow(not ASortParams.SortByCols, J,I, ARowFrom, ARowTo);
end;
end;

20
components/fpspreadsheet/tests/sortingtests.pas
View File

@ -295,14 +295,14 @@ begin
// We will sort primarily according to column A, and seconarily according
// to B. The construction allows us to determine if the sorting is correct.
for i:=0 to iLast do
MyWorksheet.WriteUTF8Text(i, col, char(ord('A')+round(SollSortNumbers[i div 2])));
MyWorksheet.WriteUTF8Text(i, col, char(ord('A')+round(SollSortNumbers[i]) div 2));
end else
begin
// The same with the rows...
for i:=0 to iLast do
MyWorksheet.WriteNumber(row+1, i+1, SollSortNumbers[i]);
MyWorksheet.WriteNumber(row+1, i, SollSortNumbers[i]);
for i:=0 to iLast do
MyWorksheet.WriteUTF8Text(row, i, char(ord('A')+round(SollSortNumbers[i div 2])));
MyWorksheet.WriteUTF8Text(row, i, char(ord('A')+round(SollSortNumbers[i]) div 2));
end;
MyWorkBook.WriteToFile(TempFile, AFormat, true);
@ -325,18 +325,12 @@ begin
fail('Error in test code. Failed to get named worksheet');
// ... and sort it.
r1 := 0; c1 := 0;
if ASortByCols then begin
c2 := 1;
r2 := iLast;
end else
begin
c2 := iLast;
r2 := 1;
end;
sortParams.Keys[0].Order := sortDir;
sortParams.Keys[1].Order := sortDir;
MyWorksheet.Sort(sortParams, r1,c1, r2, c2);
if ASortByCols then
MyWorksheet.Sort(sortParams, 0, 0, iLast, 1)
else
MyWorksheet.Sort(sortParams, 0, 0, 1, iLast);
// for debugging, to see the sorted data
MyWorkbook.WriteToFile('sorted.xls', AFormat, true);

5
components/fpspreadsheet/tests/spreadtestgui.lpi
View File

@ -48,6 +48,7 @@
<Unit1>
<Filename Value="datetests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="datetests"/>
</Unit1>
<Unit2>
<Filename Value="stringtests.pas"/>
@ -75,7 +76,6 @@
<Unit7>
<Filename Value="formattests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="formattests"/>
</Unit7>
<Unit8>
<Filename Value="colortests.pas"/>
@ -84,7 +84,6 @@
<Unit9>
<Filename Value="fonttests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fonttests"/>
</Unit9>
<Unit10>
<Filename Value="optiontests.pas"/>
@ -97,7 +96,6 @@
<Unit12>
<Filename Value="rpnformulaunit.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="rpnFormulaUnit"/>
</Unit12>
<Unit13>
<Filename Value="formulatests.pas"/>
@ -107,7 +105,6 @@
<Unit14>
<Filename Value="emptycelltests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="emptycelltests"/>
</Unit14>
<Unit15>
<Filename Value="errortests.pas"/>