Measure/Units/FormulaCalc.pas

unit FormulaCalc;

interface

uses
  sdIDTree, ZhAPI, Math, CalcDecimal;

const
  ArithmeticCharSet: set of Char = ['0'..'9', '.', '(','[','{', ')',']','}', '+','-','*','/','^', '%', '='];
  ExprsBaseCharSet: set of Char = ['h', 't', 'j', 'b', 'q', 'w', 'c', 'k', 'g', 'y', 'f', 'l'];
  ExprsExceptCharSet: set of Char = ['h', 't', 'j', 'k', 'g', 'y', 'f', 'c', 'l'];

type

  TOnGetValueEvent = function (const ACardinalNum: string): Double of object;

  TFormulaCalc = class
  private
    FTree: TsdIDTree;
    FDisplayText: string;
    FRecordText: string;
    FIndexRange: Integer;
    FOnGetValue: TOnGetValueEvent;
    FPhaseIndex: Integer;
    function GetIndexID(AKeyID: Integer): Integer;
    function GetKeyID(AIndexID: Integer): Integer;
    procedure ResetDisplayText;
    procedure ResetRecordText;

    function GetCalcText: string;
    function GetValue: Double;

    function DoOnGetValue(const ACardinalNum: string): Double;
    procedure SetIndexRange(ANodeID: Integer);
  public
    constructor Create(ATree: TsdIDTree);
    destructor Destroy; override;

    property DisplayText: string read FDisplayText;
    property RecordText: string read FRecordText;
    property Value: Double read GetValue;

    procedure SetDisplayText(const AText: string; AIndexRange: Integer);
    procedure SetRecordText(const AText: string);

    property PhaseIndex: Integer read FPhaseIndex write FPhaseIndex;
    property OnGetValue: TOnGetValueEvent read FOnGetValue write FOnGetValue;
  end;

  TPayFormula = class
  private
    FProjectData: TObject;
    FDisplayText: string;
    FStartedPrice: Double;
    FDecimal: TCalcDecimal;

    // 签约合同价
    function ContractPrice: Double;
    // 开工预付款
    function StartedSubsist: Double;
    // 材料预付款
    function MaterialSubsist: Double;
    // 本期本阶段结算价
    function StageSettlement: Double;
    // 100/200/.../900章本期完成计量
    function ChapterStageGather(AChapter: Integer): Double;

    function GetCalcText: string;
    function GetValue: Double;
  public
    constructor Create(AProjectData: TObject);
    destructor Destroy; override;

    function Calculate(const ADisplayText: string; AStartedPrice: Double = 0): Double;

    property Decimal: TCalcDecimal read FDecimal write FDecimal;
  end;

implementation

uses
  SysUtils, ProjectData, PhaseData, UtilMethods;

{ TFormulaCalc }

constructor TFormulaCalc.Create(ATree: TsdIDTree);
begin
  FTree := ATree;
end;

destructor TFormulaCalc.Destroy;
begin
  inherited;
end;

function TFormulaCalc.DoOnGetValue(const ACardinalNum: string): Double;
begin
  Result := 0;
  if Assigned(FOnGetValue) then
    Result := FOnGetValue(ACardinalNum);
end;

function TFormulaCalc.GetCalcText: string;
var
  iPos, iCharIndex: Integer;
  sNode: string;
begin
  Result := FRecordText;
  iPos := Pos('@', Result);
  while iPos > 0 do
  begin
    sNode:= '';
    for iCharIndex := iPos + 1 to Length(Result) do
    begin
      if Result[iCharIndex] in ['0'..'9', 'a'..'d', 'A'..'D'] then
        sNode := sNode + Result[iCharIndex]
      else
        Break;
    end;
    Result := StringReplace(Result, '@'+sNode, FloatToStr(DoOnGetValue(sNode)), [rfReplaceAll, rfIgnoreCase]);
    iPos := Pos('@', Result);
  end;
end;

function TFormulaCalc.GetIndexID(AKeyID: Integer): Integer;
begin
  with FTree do
    Result := IndexOf(FindNode(AKeyID));
end;

function TFormulaCalc.GetKeyID(AIndexID: Integer): Integer;
begin
  if AIndexID > -1 then
    Result := FTree.Items[AIndexID].ID
  else
    Result := -1;
end;

function TFormulaCalc.GetValue: Double;
begin
  Result := EvaluateExprs(GetCalcText);
end;

procedure TFormulaCalc.ResetDisplayText;
var
  iCharIndex, iLength: Integer;
  sChar, sID, sFormula: string;
begin
  iCharIndex := 1;
  iLength := Length(FRecordText);
  sFormula := '';

  while iCharIndex <= iLength do
  begin
    if FRecordText[iCharIndex] = '@' then
    begin
      Inc(iCharIndex);
      if FRecordText[iCharIndex] in ['A'..'D', 'a'..'d'] then
      begin
        sChar := FRecordText[iCharIndex];
        Inc(iCharIndex);
        sID := '';
        while (FRecordText[iCharIndex] in ['0'..'9']) and (iCharIndex <= iLength) do
        begin
          sID := sID + FRecordText[iCharIndex];
          Inc(iCharIndex);
        end;
        if GetIndexID(StrToIntDef(sID, -1)) > -1 then
          sFormula := sFormula + sChar + IntToStr(GetIndexID(StrToIntDef(sID, -1)) + 1);
      end;
    end
    else if FRecordText[iCharIndex] in ['0'..'9', '.', '(','[','{', ')',']','}', '+','-','*','/','^', '%', '='] then
    begin
      sFormula := sFormula + FRecordText[iCharIndex];
      Inc(iCharIndex);
    end;
  end;
  FDisplayText := sFormula;
end;

procedure TFormulaCalc.ResetRecordText;
var
  iCharIndex, iLength: Integer;
  sChar, sID, sFormula: string;
begin
  iCharIndex := 1;
  iLength := Length(FDisplayText);
  sFormula := '';

  while iCharIndex <= iLength do
  begin
    if FDisplayText[iCharIndex] in ['A'..'D', 'a'..'d'] then
    begin
      sChar := FDisplayText[iCharIndex];
      Inc(iCharIndex);
      sID := '';
      while FDisplayText[iCharIndex] in ['0'..'9'] do
      begin
        sID := sID + FDisplayText[iCharIndex];
        Inc(iCharIndex);
      end;
      if FDisplayText[iCharIndex] in ['.', '%'] then
        Raise Exception.Create('表达式非法' + FDisplayText + '！')
      else if StrToIntDef(sID, -1) > FIndexRange then
        Raise Exception.Create('表达式仅可以引用前项清单！')
      else if GetKeyID(StrToIntDef(sID, -1) - 1) = -1 then
        Raise Exception.Create('表达式非法' + FDisplayText + '！')
      else
        sFormula := sFormula + '@' + sChar + IntToStr(GetKeyID(StrToIntDef(sID, -1) - 1));
    end
    else if FDisplayText[iCharIndex] in ['0'..'9', '.', '(','[','{', ')',']','}', '+','-','*','/','^', '%', '='] then
    begin
      sFormula := sFormula + FDisplayText[iCharIndex];
      Inc(iCharIndex);
    end;
  end;
  FRecordText := sFormula
end;

procedure TFormulaCalc.SetDisplayText(const AText: string; AIndexRange: Integer);
begin
  SetIndexRange(AIndexRange);
  FDisplayText := AText;
  FRecordText := '';
  ResetRecordText;
end;

procedure TFormulaCalc.SetIndexRange(ANodeID: Integer);
var
  stnNode: TsdIDTreeNode;
begin
  stnNode := FTree.FindNode(ANodeID);
  while Assigned(stnNode.Parent) do
    stnNode := stnNode.Parent;
  FIndexRange := FTree.IndexOf(stnNode);
end;

procedure TFormulaCalc.SetRecordText(const AText: string);
begin
  FRecordText := AText;
  FDisplayText := '';
  ResetDisplayText;
end;

{ TPayFormula }

function TPayFormula.Calculate(const ADisplayText: string; AStartedPrice: Double = 0): Double;
begin
  FDisplayText := ADisplayText;
  FStartedPrice := AStartedPrice;
  Result := GetValue;
end;

function TPayFormula.ChapterStageGather(AChapter: Integer): Double;
begin
  with TProjectData(FProjectData).PhaseData do
    if Active then
      Result := StageData.ChapterStageGather[AChapter]
    else
      Result := 0;
end;

function TPayFormula.ContractPrice: Double;
begin
  Result := TProjectData(FProjectData).ProjProperties.ContractPrice;
end;

constructor TPayFormula.Create(AProjectData: TObject);
begin
  FProjectData := AProjectData;
end;

destructor TPayFormula.Destroy;
begin
  inherited;
end;

function TPayFormula.GetCalcText: string;
begin
  Result := StringReplace(FDisplayText, 'htj', FloatToStr(ContractPrice), [rfReplaceAll, rfIgnoreCase]);
  Result := StringReplace(Result, 'kgyfk', FloatToStr(StartedSubsist), [rfReplaceAll, rfIgnoreCase]);
  Result := StringReplace(Result, 'clyfk', FloatToStr(MaterialSubsist), [rfReplaceAll, rfIgnoreCase]);
  Result := StringReplace(Result, 'ybbqwc', FloatToStr(ChapterStageGather(1)), [rfReplaceAll, rfIgnoreCase]);
  Result := StringReplace(Result, 'bqwc', FloatToStr(StageSettlement), [rfReplaceAll, rfIgnoreCase]);
end;

function TPayFormula.GetValue: Double;
begin
  if Assigned(Decimal) then
    Result := Decimal.TotalPrice.RoundTo(EvaluateExprs(GetCalcText))
  else
    Result := TotalPriceRoundTo(EvaluateExprs(GetCalcText));
end;

function TPayFormula.MaterialSubsist: Double;
begin
  Result := TProjectData(FProjectData).ProjProperties.MaterialSubsist;
end;

function TPayFormula.StageSettlement: Double;
begin
  with TProjectData(FProjectData).PhaseData do
    if Active then
    begin
      // 初次达到起扣金额时，bqwc计数值，取累计完成计量-起扣金额
      if FStartedPrice = 0 then
        Result := StageData.StageSettlement[1, 4]
      else
        Result := StageData.StageSettlement[2, 4] - FStartedPrice;
    end
    else
      Result := 0;
end;

function TPayFormula.StartedSubsist: Double;
begin
  Result := TProjectData(FProjectData).ProjProperties.StartedSubsisit;
end;

end.