fatexpression.~pas

dede 的源代码 3.10b

        if (Tokens[I].TokenType = ttParenthesis) and (Tokens[I].Text = '(') then
          Inc(DelimitorLevel) else
        if (Tokens[I].TokenType = ttParenthesis) and (Tokens[I].Text = ')') then
          Dec(DelimitorLevel) else
        if (Tokens[I].TokenType = ttParamDelimitor) and (DelimitorLevel = 0) then begin
          Delimitor := I - 1;
          FTokens.Delete(I);
          Break;
        end;

        if DelimitorLevel < 0 then begin
          raise Exception.Create('Function parse error.');
          Exit;
        end;
      end;

      if Delimitor = -1 then Delimitor := TokenCount - 1;
      for I := 1 to Delimitor do begin
        FList.Add(Tokens[1]);
        FTokens.Delete(1);
      end;
      FChild := TExpNode.Create(FOwner, Self, FList);
      FList.Clear;
      FChild.Build;
      FChildren.Add(FChild);
    end;
  finally
    FList.Free;
  end;
  Result := True;
end;

procedure TExpNode.SplitToChildren(TokenIndex: Integer);
var Left, Right: TList;
  I: Integer;
  FChild: TExpNode;
begin
  Left := TList.Create;
  Right := TList.Create;

  try
    if TokenIndex < TokenCount - 1 then
      for I := TokenCount - 1 downto TokenIndex + 1 do begin
        Right.Insert(0, FTokens[I]);
        FTokens.Delete(I);
      end;

    if Right.Count > 0 then
    begin
      FChild := TExpNode.Create(FOwner, Self, Right);
      FChildren.Insert(0, FChild);
      FChild.Build;
    end;

    if TokenIndex > 0 then
      for I := TokenIndex - 1 downto 0 do begin
        Left.Insert(0, FTokens[I]);
        FTokens.Delete(I);
      end;

    FChild := TExpNode.Create(FOwner, Self, Left);
    FChildren.Insert(0, FChild);
    FChild.Build;
  finally
    FToken := Tokens[0];
    Left.Free;
    Right.Free;
  end;
end;

function TExpNode.GetChildren(Index: Integer): TExpNode;
begin
  Result := TExpNode(FChildren[Index]);
end;

function TExpNode.FindLSOTI: Integer;
var Lvl, I, LSOTI, NewOperPriority, OperPriority: Integer;
begin
  Lvl := 0; // Lvl = parenthesis level
  I := 0;
  LSOTI := - 1;
  OperPriority := 9;

  repeat
    if Tokens[I].TokenType = ttParenthesis then begin
      if Tokens[I].Text = '(' then
        Inc(Lvl) else
      if Tokens[I].Text = ')' then
        Dec(Lvl);

      if Lvl < 0 then begin
        //raise Exception.CreateFmt('Parenthesis mismatch at level %d, token %d.', [Level, I]);
        raise Exception.Create('Compile error: parenthesis mismatch.');
        Exit;
      end;
    end;

    if (Tokens[I].TokenType = ttOperation) and (Lvl = 0) then begin
      NewOperPriority := Pos(Tokens[I].Text, STR_OPERATION);
      if NewOperPriority <= OperPriority then begin
        OperPriority := NewOperPriority;
        LSOTI := I;
      end;
    end;

    Inc(I);
  until I >= TokenCount;

  Result := LSOTI;
end;

function Exl(Value: Integer): Double;
begin
  if Value <= 1 then
    Result := Value else
    Result := Value * Exl(Value - 1);
end;

function TExpNode.Evaluate: Double;
var Args: array of Double;
  Count, I: Integer;
  Done: Boolean;
begin
  Result := 0;
  if FToken.TokenType = ttString then begin
    Count := FChildren.Count;
    SetLength(Args, Count);
    for I := 0 to Count - 1 do
      Args[I] := Children[I].Calculate;

    if Assigned(FOnEvaluate) then
      FOnEvaluate(Self, FToken.Text, Args, High(Args) + 1, Result, Done) else
    if FOwner is TFatExpression then
      TFatExpression(FOwner).Evaluate(FToken.Text, Args, Result) else
    if FOwner is TFunction then
      TFunction(FOwner).EvalArgs(Self, FToken.Text, Args, High(Args) + 1, Result);
  end;
end;

function TExpNode.Calculate: Double;
var Error: Integer;
  DivX, DivY: Double;
begin
  Result := 0;
  if (FToken = NIL) or (TokenCount = 0) then
    Exit;

  if TokenCount = 1 then begin
    if FToken.TokenType = ttNumeric then begin
      Val(FToken.Text, Result, Error);
    end else
    if FToken.TokenType = ttString then begin
      Result := Evaluate;
    end else
    if FToken.TokenType = ttOperation then begin
      if FChildren.Count <> OperParamateres(FToken.Text) then begin
        raise Exception.Create('Calculate error: syntax tree fault.');
        Exit;
      end;
      if FToken.Text = '+' then
        Result := Children[0].Calculate + Children[1].Calculate else
      if FToken.Text = '-' then
        Result := Children[0].Calculate - Children[1].Calculate else
      if FToken.Text = '*' then
        Result := Children[0].Calculate * Children[1].Calculate else
      if FToken.Text = '/' then begin
        DivX := Children[0].Calculate;
        DivY := Children[1].Calculate;
        if DivY <> 0 then Result := DivX / DivY else
          begin
            raise Exception.CreateFmt('Calculate error: "%f / %f" divison by zero.', [DivX, DivY]);
            Exit;
          end;
      end else
      if FToken.Text = '^' then
        Result := Power(Children[0].Calculate, Children[1].Calculate) else
      if FToken.Text = '!' then
        Result := Exl(Round(Children[0].Calculate));
    end;
  end;
end;

function TExpNode.GetToken(Index: Integer): TExpToken;
begin
  Result := TExpToken(FTokens[Index]);
end;

function TExpNode.TokenCount: Integer;
begin
  Result := FTokens.Count;
end;








constructor TFunction.Create(AOwner: TObject);
begin
  inherited Create;
  FOwner := AOwner;
  FAsString := '';
  FName := '';
  FArgCount := 0;
  FArgs := TStringList.Create;
end;

destructor TFunction.Destroy;
begin
  FArgs.Free;
  inherited;
end;

function TFunction.Call(Values: array of Double): Double;
var Token: TExpToken;
  Tree: TExpNode;
  Parser: TExpParser;
  I: Integer;
begin
  SetLength(FValues, High(Values) + 1);
  for I := 0 to High(Values) do
    FValues[I] := Values[I];
    
  Parser := TExpParser.Create;
  try
    Parser.Expression := FFunction;
    Token := Parser.ReadFirstToken;
    while Token <> NIL do Token := Parser.ReadNextToken;

    Tree := TExpNode.Create(Self, NIL, Parser.TokenList);
    try
      with Tree do begin
        Build;
        Result := Calculate;
      end;
    finally
      Tree.Free;
    end;
  finally
    Parser.Free;
  end;
end;

procedure TFunction.EvalArgs(Sender: TObject; Eval: String; Args: array of Double; ArgCount: Integer; var Value: Double);
var I: Integer;
begin
  for I := 0 to FArgs.Count - 1 do
     if UpperCase(FArgs[I]) = UpperCase(Eval) then begin
      Value := FValues[I];
      Exit;
    end;

  if FOwner is TFatExpression then
    TFatExpression(FOwner).Evaluate(Eval, Args, Value);
end;

procedure TFunction.SetAsString(const Value: String);
var Head: String;
  HeadPos: Integer;
  Parser: TExpParser;
  Token: TExpToken;
  ExpectParenthesis, ExpectDelimitor: Boolean;
begin
  FArgs.Clear;
  FArgCount := 0;
  FAsString := Value;
  FHead := '';
  FFunction := '';
  FName := '';

  HeadPos := Pos('=', FAsString);
  if HeadPos = 0 then Exit;
  Head := Copy(FAsString, 1, HeadPos - 1);
  FFunction := FAsString;
  Delete(FFunction, 1, HeadPos);
  Parser := TExpParser.Create;
  try
    Parser.Expression := Head;
    Token := Parser.ReadFirstToken;
    if (Token = NIL) or (Token.TokenType <> ttString) then begin
      raise Exception.CreateFmt('Function "%s" is not valid.', [FAsString]);
      Exit;
    end;
    FName := Token.Text;

    Token := Parser.ReadNextToken;
    if Token = NIL then Exit;
    if Token.TokenType = ttParenthesis then begin
      if Token.Text = '(' then ExpectParenthesis := True else
      begin
        raise Exception.CreateFmt('Function header "%s" is not valid.', [Head]);
        Exit;
      end;
    end else
    ExpectParenthesis := False;

    ExpectDelimitor := False;
    while Token <> NIL do begin
      Token := Parser.ReadNextToken;
      if Token <> NIL then begin
        if Token.TokenType = ttParenthesis then begin
          if ExpectParenthesis and (Token.Text = ')') then Exit else
          begin
            raise Exception.CreateFmt('Function header "%s" is not valid.', [Head]);
            Exit;
          end;
        end;

        if ExpectDelimitor then begin
          if (Token.TokenType <> ttParamDelimitor) and (Token.TokenType <> ttParenthesis) then begin
            raise Exception.Create('Function parse error: delimitor ";" expected between arguments.');
            Exit;
          end;
          ExpectDelimitor := False;
          Continue;
        end;

        if Token.TokenType = ttString then begin
          FArgs.Add(Token.Text);
          FArgCount := FArgs.Count;
          ExpectDelimitor := True;
        end;
      end;
    end;
    if ExpectParenthesis then
      raise Exception.CreateFmt('Function header "%s" is not valid.', [Head]);
  finally
    Parser.Free;
  end;
end;





constructor TFatExpression.Create;
begin
  inherited;
  FText := '';
  FInfo := 'TFatExpression v1.0 by [e-mail]';
  FFunctions := TStringList.Create;
end;

destructor TFatExpression.Destroy;
begin
  FFunctions.Free;
  inherited;
end;

procedure TFatExpression.Compile;
var Token: TExpToken;
  Tree: TExpNode;
  Parser: TExpParser;
begin
  Parser := TExpParser.Create;
  try
    Parser.Expression := FText;
    Token := Parser.ReadFirstToken;
    while Token <> NIL do
      Token := Parser.ReadNextToken;

    Tree := TExpNode.Create(Self, NIL, Parser.TokenList);
    try
      with Tree do begin
        Build;
        FValue := Calculate;
      end;
    finally
      Tree.Free;
    end;
  finally
    Parser.Free;
  end;
end;

function TFatExpression.FindFunction(FuncName: String): TFunction;
var F: TFunction;
  I: Integer;
begin
  Result := NIL;
  for I := 0 to FFunctions.Count - 1 do
    if Trim(FFunctions[I]) <> '' then begin
      F := TFunction.Create(Self);
      F.AsString := FFunctions[I];
      if UpperCase(F.Name) = UpperCase(FuncName) then begin
        Result := F;
        Exit;
      end;
      F.Free;
    end;
end;

procedure TFatExpression.SetInfo(Value: String);
begin
  //
end;

procedure TFatExpression.Evaluate(Eval: String; Args: array of Double; var Value: Double);
var Func: TFunction;
  Done: Boolean;
begin
  Done := False;
  if (EvaluateOrder = eoEventFirst) and Assigned(FOnEvaluate) then begin
    FOnEvaluate(Self, Eval, Args, High(Args) + 1, Value, Done);
    if Done then Exit;
  end else
  Value := 0;

  Func := FindFunction(Eval);
  if Func <> NIL then begin
    Value := Func.Call(Args);
    Func.Free;
    Exit;
  end;

  if (EvaluateOrder = eoInternalFirst) and Assigned(FOnEvaluate) then
    FOnEvaluate(Self, Eval, Args, High(Args) + 1, Value, Done) else
    Value := 0;
end;

function TFatExpression.GetValue: Double;
begin
  Compile;
  Result := FValue;
end;

procedure TFatExpression.SetFunctions(Value: TStringList);
begin
  FFunctions.Assign(Value);
end;


end.