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

fpspreadsheet: Introduce recursive calculation of cells depending on non-yet calculated cells. Add demo "test_recursive" in folder "other".

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3271 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2014-07-03 08:52:12 +00:00
parent b15721dd9b
commit 4741c857a8
3 changed files with 215 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files

103
components/fpspreadsheet/examples/other/test_recursive_calc.lpi Normal file
View File

@ -0,0 +1,103 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="test_recursive_calc"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="2">
<Item1 Name="Debug" Default="True"/>
<Item2 Name="Release">
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
</SearchPaths>
<CodeGeneration>
<SmartLinkUnit Value="True"/>
</CodeGeneration>
<Linking>
<Debugging>
<StripSymbols Value="True"/>
</Debugging>
<LinkSmart Value="True"/>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
</Item2>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="laz_fpspreadsheet"/>
</Item1>
</RequiredPackages>
<Units Count="1">
<Unit0>
<Filename Value="test_recursive_calc.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="test_recursive_calc"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
</SearchPaths>
<CodeGeneration>
<SmartLinkUnit Value="True"/>
</CodeGeneration>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf2Set"/>
</Debugging>
<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>

56
components/fpspreadsheet/examples/other/test_recursive_calc.pas Normal file
View File

@ -0,0 +1,56 @@
{ This demo is a test for recursive calculation of cells. The cell formulas
are constructed such that the first cell depends on the second, and the second
cell depends on the third one. Only the third cell contains a number.
Therefore calculation has to be done recursively until the independent third
cell is found. }
program test_recursive_calc;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Classes, laz_fpspreadsheet
{ you can add units after this },
math, fpspreadsheet, fpsfunc;
var
workbook: TsWorkbook;
worksheet: TsWorksheet;
begin
workbook := TsWorkbook.Create;
try
worksheet := workbook.AddWorksheet('Calc_test');
worksheet.Options := worksheet.Options + [soCalcBeforeSaving];
worksheet.WriteColWidth(0, 20);
// A1
worksheet.WriteUTF8Text(0, 0, '=B2+1');
// B1
worksheet.WriteRPNFormula(0, 1, CreateRPNFormula(
RPNCellValue('B2',
RPNNumber(1,
RPNFunc(fekAdd, nil)))));
// A2
worksheet.WriteUTF8Text(1, 0, '=B3+1');
// B2
worksheet.WriteRPNFormula(1, 1, CreateRPNFormula(
RPNCellValue('B3',
RPNNumber(1,
RPNFunc(fekAdd, nil)))));
// A3
worksheet.WriteUTF8Text(2, 0, '(not dependent)');
// B3
worksheet.WriteNumber(2, 1, 1);
workbook.WriteToFile('test_calc.xls', sfExcel8, true);
finally
workbook.Free;
end;
end.

78
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -361,6 +361,9 @@ const
);
type
{@@ State flags while calculating formulas }
TsCalcState = (csNotCalculated, csCalculating, csCalculated);
{@@ Cell structure for TsWorksheet
The cell record contains information on the location of the cell (row and
column index), on the value contained (number, date, text, ...), and on
@ -396,6 +399,8 @@ type
NumberFormat: TsNumberFormat;
NumberFormatStr: String;
RGBBackgroundColor: TFPColor; // only valid if BackgroundColor=scRGBCOLOR
{ Status flags }
CalcState: TsCalcState;
end;
{@@ Pointer to a TCell record }
@ -471,8 +476,13 @@ type
FOptions: TsSheetOptions;
FOnChangeCell: TsCellEvent;
FOnChangeFont: TsCellEvent;
procedure CalcFormulaCallback(data, arg: Pointer);
{ Setter/Getter }
function GetFormatSettings: TFormatSettings;
{ Callback procedures called when iterating through all cells }
procedure CalcFormulaCallback(data, arg: Pointer);
procedure CalcStateCallback(data, arg: Pointer);
procedure RemoveCallback(data, arg: pointer);
protected
@ -1019,6 +1029,7 @@ resourcestring
lpIllegalNumberFormat = 'Illegal number format.';
lpSpecifyNumberOfParams = 'Specify number of parameters for function %s';
lpIncorrectParamCount = 'Funtion %s requires at least %d and at most %d parameters.';
lpCircularReference = 'Circular reference found when calculating worksheet formulas';
lpTRUE = 'TRUE';
lpFALSE = 'FALSE';
lpErrEmptyIntersection = '#NULL!';
@ -1431,20 +1442,50 @@ begin
end;
{@@
Helper method marking all cells with formulas as "not calculated". This flag
is needed for recursive calculation of the entire worksheet.
}
procedure TsWorksheet.CalcStateCallback(data, arg: Pointer);
var
cell: PCell;
begin
Unused(arg);
cell := PCell(data);
if Length(cell^.RPNFormulaValue) > 0 then
cell^.CalcState := csNotCalculated;
end;
{@@
Calculates all rpn formulas of the worksheet.
}
procedure TsWorksheet.CalcFormulas;
var
node: TAVLTreeNode;
begin
Node := FCells.FindLowest;
// Step 1 - mark all formula cells as "not calculated"
node := FCells.FindLowest;
while Assigned(node) do begin
CalcStateCallback(node.Data, nil);
node := FCells.FindSuccessor(node);
end;
// Step 2 - calculate cells. If a not-calculated cell is found it is
// calculated and then marked as such.
node := FCells.FindLowest;
while Assigned(Node) do begin
CalcFormulaCallback(Node.Data, nil);
node := FCells.FindSuccessor(node);
end;
end;
{@@
Calculates the rpn formula assigned to a cell.
Should not be called by itself because the result may depend on other cells
which may have not yet been calculated. It is better to call CalcFormulas
instead.
@param ACell Cell containing the rpn formula.
}
procedure TsWorksheet.CalcRPNFormula(ACell: PCell);
var
@ -1461,14 +1502,20 @@ begin
then
exit;
ACell^.CalcState := csCalculating;
args := TsArgumentStack.Create;
try
for i := 0 to Length(ACell^.RPNFormulaValue) - 1 do begin
fe := ACell^.RPNFormulaValue[i]; // "formula element"
fe := ACell^.RPNFormulaValue[i]; // fe = "formula element"
case fe.ElementKind of
fekCell, fekCellRef:
begin
cell := FindCell(fe.Row, fe.Col);
case cell^.CalcState of
csNotCalculated: CalcRPNFormula(cell);
csCalculating : raise Exception.Create(lpCircularReference);
end;
args.PushCell(cell);
end;
fekCellRange: ;
@ -1499,21 +1546,13 @@ begin
end;
// Result of function
val := func(args, fe.ParamsNum);
// Push result on stack for usage by next function or as final result
args.Push(val);
{
// Push valid result on stack, exit in case of error
case val.ArgumentType of
atNumber, atString, atBool, atEmpty:
args.Push(val);
atError:
begin
WriteErrorValue(ACell, val.ErrorValue);
exit;
end;
end;
}
end; // case
end; // for
{ When all formula elements have been processed the stack contains the
final result. }
if args.Count = 1 then begin
val := args.Pop;
case val.ArgumentType of
@ -1525,13 +1564,8 @@ begin
end;
end else
WriteErrorValue(ACell, errArgError);
{
// This case is a program error --> raise an exception
raise Exception.CreateFmt('Incorrect argument count of the formula in cell %s', [
GetCellString(ACell^.Row, ACell^.Col, [])
]);
}
finally
ACell^.CalcState := csCalculated;
args.Free;
end;
end;