zparser.pas

一款由Zlib来的数学公式解析器

  while I < FVarCount do
  begin
    if FVars[I].VarName = VarName then
    begin
      Result := FVars[I].VarValue;
      Exit;
    end;
    Inc(I);
  end;
  Result := NULL;
end;

{ Set new value to variable }
procedure TZParser.SetVar(VarName: string; VarValue: Variant);
var
  I: Integer;
begin
  I := 0;
  VarName := AnsiUpperCase(VarName);
  while I < FVarCount do
  begin
    if FVars[I].VarName = VarName then
    begin
      if VarType(VarValue) <> varNull then
        FVars[I].VarValue := ConvType(VarValue);
      Exit;
    end;
    Inc(I);
  end;

  if I >= MAX_PARSE_VARS then Exit;
  FVars[I].VarName  := VarName;
  FVars[I].VarValue := ConvType(VarValue);
  Inc(FVarCount);
end;

{ Get function name by it handle }
function TZParser.GetFuncName(FuncIndex: Integer): string;
begin
  if FuncIndex >= FFuncCount then
    raise EParseException.Create(ResStr(SIncorFuncIdx));
  Result := FFuncs[FuncIndex].FuncName;
end;

{ Get function handle }
function TZParser.GetFunc(FuncName: string): TParseFunc;
var
  I: Integer;
begin
  FuncName := AnsiUpperCase(FuncName);
  for I := 0 to FFuncCount-1 do
    if UpperCase(FFuncs[I].FuncName) = FuncName then
    begin
      Result := FFuncs[I].FuncPtr;
      Exit;
    end;
  Result := nil;
end;

{ Set new function handle }
procedure TZParser.SetFunc(FuncName: string; FuncPtr: TParseFunc);
var
  I: Integer;
begin
  I := 0;
  FuncName := AnsiUpperCase(FuncName);
  while I < FFuncCount do
  begin
    if FFuncs[I].FuncName = FuncName then
    begin
      if Assigned(FuncPtr) then
        FFuncs[i].FuncPtr := FuncPtr;
      Exit;
    end;
    Inc(I);
  end;
  if I >= MAX_PARSE_FUNCS then Exit;
  FFuncs[I].FuncName := FuncName;
  FFuncs[I].FuncPtr  := FuncPtr;
  Inc(FFuncCount);
end;

{ Convert types of two variant values }
function TZParser.ConvType(Value: Variant): Variant;
begin
  case VarType(Value) of
    varByte, varSmallint, varInteger:
      Result := VarAsType(Value, varInteger);
    varSingle, varDouble, varCurrency:
      Result := VarAsType(Value, varDouble);
    varDate, varOleStr, varString, varVariant:
      Result := VarAsType(Value, varString);
    varBoolean:
      Result := Value;
    varNull:
      Result := VarAsType(0, varInteger);
    else
      raise EParseException.Create(ResStr(STypesMismatch));
  end;
end;

{ Convert types of two variant values }
procedure TZParser.CheckTypes(Value1: Variant; var Value2: Variant);
begin
  case VarType(Value1) of
    varInteger:
      if VarType(Value2) = varString then
        Value2 := StrToFloatEx(Value2)
      else
        Value2 := VarAsType(Value2, varInteger);
    varString:
        Value2 := VarAsType(Value2, varString);
    varDouble:
      if VarType(Value2) = varString then
        Value2 := StrToFloatEx(Value2)
      else
        Value2 := VarAsType(Value2, varDouble);
    varBoolean:
      case VarType(Value2) of
        varInteger, varDouble:
          Value2 := (Value2 <> 0);
        varString:
          Value2 := (StrToFloatEx(Value2) <> 0);
        varBoolean:
        else
          raise EParseException.Create(ResStr(STypesMismatch));
      end;
    else
      raise EParseException.Create(ResStr(STypesMismatch));
  end;
end;

{ Calculate an equation }
function TZParser.Evalute: Variant;
var
  I: Integer;
  Value1, Value2, Sgn: Variant;
  Op: string;
  FuncPtr: TParseFunc;
begin
  FStackCount := 0;
  for I := 0 to FParseCount-1 do
  begin
    case FParseItems[I].ItemType of
      ptFunction:
        begin
          FuncPtr := GetFunc(FParseItems[I].ItemValue);
          if Assigned(FuncPtr) then
            Push(FuncPtr(Self))
          else
            raise EParseException.CreateFmt(ResStr(SFuncNotFound),
              [FParseItems[I].ItemValue]);
        end;
      ptVariable:
        begin
          Value1 := GetVar(FParseItems[I].ItemValue);
          if VarType(Value1) = varNull then
            raise EParseException.CreateFmt(ResStr(SVarNotFound),
              [FParseItems[I].ItemValue]);
          Push(Value1);
        end;
      ptFloat, ptInteger, ptString, ptBoolean:
        Push(FParseItems[I].ItemValue);
      ptDelim:
        begin
          Op := VarAsType(FParseItems[I].ItemValue, varString);

          if Op[1] in ['+','-','*','/','%'] then
          begin
            Value2 := Pop;
            Value1 := Pop;
            CheckTypes(Value1, Value2);
            case Op[1] of
              '+': Push(Value1 + Value2);
              '-': Push(Value1 - Value2);
              '*': Push(Value1 * Value2);
              '/': Push(Value1 / Value2);
              '%': Push(Value1 mod Value2);
            end;
            Continue;
          end;

          if (Op = '=') or (Op = '<') or (Op = '>') then
          begin
            Value2 := Pop;
            Value1 := Pop;
            CheckTypes(Value1, Value2);
            case Op[1] of
              '=': Push(Value1 = Value2);
              '<': Push(Value1 < Value2);
              '>': Push(Value1 > Value2);
            end;
            Continue;
          end;

          if (Op = '>=') or (Op = '<=') or (Op = '<>') then
          begin
            Value2 := Pop;
            Value1 := Pop;
            CheckTypes(Value1, Value2);
            if Op='>=' then Push(Value1 >= Value2);
            if Op='<=' then Push(Value1 <= Value2);
            if Op='<>' then Push(Value1 <> Value2);
            Continue;
          end;

          if (Op = tokAND) or (Op = tokOR) or (Op = tokXOR) then
          begin
            Value1 := Pop;
            Value2 := Pop;
            if Op = tokAND then Push(Value1 and Value2);
            if Op = tokOR then  Push(Value1 or Value2);
            if Op = tokXOR then Push((not Value1 and Value2) or (Value1 and not Value2));
            Continue;
          end;

          if Op = '~' then
          begin
            Value1 := Pop;
            Push(-Value1);
            Continue;
          end;

          if Op = tokNOT then
          begin
            Value1 := Pop;
            CheckTypes(True, Value1);
            Push(not Value1);
            Continue;
          end;

          if Op = '^' then            
          begin
            Value2 := VarAsType(Pop,varDouble);
            Value1 := VarAsType(Pop,varDouble);
            if (Value1 < 0) and ((Value2 mod 2) = 1) then Sgn := -1
            else Sgn := 1;
            Push(Sgn*Power(Abs(Value1),Value2));
            Continue;
          end;

          if Op = tokLIKE then
          begin
            Value2 := VarAsType(Pop, varString);
            Value1 := VarAsType(Pop, varString);
            Push(IsMatch(Value2,Value1));
            Continue;
          end;

          raise EParseException.Create(ResStr(SIncorOperate));
        end;
    end;
  end;

  Result := Pop;
  if FStackCount > 0 then
    raise EParseException.Create(ResStr(SEvalError));
end;

{ Push value to stack }
procedure TZParser.Push(Value: Variant);
begin
  if FStackCount >= MAX_PARSE_STACK then
    raise EParseException.Create(ResStr(SStackFull));
  FParseStack[FStackCount] := Value;
  Inc(FStackCount);
end;

{ Pop value from stack }
function TZParser.Pop: Variant;
begin
  if FStackCount = 0 then
    raise EParseException.Create(ResStr(SStackEmpty));
  Dec(FStackCount);
  Result := FParseStack[FStackCount];
end;

{ Clear all variables and equation }
procedure TZParser.Clear;
begin
  FStackCount := 0;
  FParseCount := 0;
  FVarCount   := 0;
  FEquation   := '';
end;

{ Define function }
function TZParser.CheckFunc(var Buffer: string): Boolean;
var
  I: Integer;
  Token: string;
begin
  I := 1;
  Result := False;
  while (I <= Length(Buffer)) and (Buffer[I] in [' ',#9,#10,#13]) do
    Inc(I);
  if Buffer = '' then
    Exit;
  if Buffer[I] = '(' then
  begin
    Result := True;
    ExtractToken(Buffer, Token);
  end;
end;

{****************************************************}

{ Register component in component palette }
procedure Register;
begin
  RegisterComponents(ZEOS_PALETTE, [TZParser]);
end;

{************** User functions implementation **************}

{ Get current date and time }
function FuncNow(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 0 then
    EParseException.CreateFmt(ResStr(SIncorFuncParam),[tokNOW]);
  Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', Now());
end;

{ Get maximum value }
function FuncMax(Sender: TZParser): Variant;
var
  Count: Integer;
  Temp:  Variant;
begin
  Count := Sender.Pop;
  if Count = 0 then
    EParseException.CreateFmt(ResStr(SIncorFuncParam),[tokMAX]);
  Result := Sender.Pop;
  Dec(Count);
  while Count > 0 do
  begin
    Temp := Sender.Pop;
    if Temp > Result then Result := Temp;
    Dec(Count);
  end;
end;

{ Get minimum value }
function FuncMin(Sender: TZParser): Variant;
var
  Count: Integer;
  Temp:  Variant;
begin
  Count := Sender.Pop;
  if Count = 0 then
    EParseException.CreateFmt(ResStr(SIncorFuncParam),[tokMIN]);
  Result := Sender.Pop;
  Dec(Count);
  while Count > 0 do
  begin
    Temp := Sender.Pop;
    if Temp < Result then Result := Temp;
    Dec(Count);
  end;
end;

{ Calculate sum of values }
function FuncSum(Sender: TZParser): Variant;
var
  Count: Integer;
begin
  Count := Sender.Pop;
  if Count = 0 then
    EParseException.CreateFmt(ResStr(SIncorFuncParam),[tokSUM]);
  Result := Sender.Pop;
  Dec(Count);
  while Count > 0 do
  begin
    Result := Result + Sender.Pop;
    Dec(Count);
  end;
end;

{ Get result by value }
function FuncIIf(Sender: TZParser): Variant;
var
  Count: Integer;
  Temp, Temp1, Temp2: Variant;
begin
  Count := Sender.Pop;
  if Count <> 3 then
    EParseException.CreateFmt(ResStr(SIncorFuncParam),[tokIIF]);
  Temp2 := Sender.Pop;
  Temp1 := Sender.Pop;
  Temp := VarAsType(Sender.Pop, varBoolean);
  if Temp then Result := Temp1
  else Result := Temp2;
end;

{ Evalue sinus value }
function FuncSin(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(ResStr(SIncorFuncParam),[tokSIN]);
  Result := Sin(Sender.Pop);
end;

{ Evalue cosinus value }
function FuncCos(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(ResStr(SIncorFuncParam),[tokCOS]);
  Result := Cos(Sender.Pop);
end;

{ Evalue tangens value }
function FuncTan(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(ResStr(SIncorFuncParam),[tokTAN]);
  Result := Tan(Sender.Pop);
end;

{ Evalue exponent value }
function FuncExp(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(ResStr(SIncorFuncParam),[tokEXP]);
  Result := Exp(Sender.Pop);
end;

{ Evalue natural logoriphm value }
function FuncLn(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(ResStr(SIncorFuncParam),[tokLN]);
  Result := Ln(Sender.Pop);
end;

{ Evalue square root value }
function FuncSqrt(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(ResStr(SIncorFuncParam),[tokSQRT]);
  Result := Sqrt(Sender.Pop);
end;

{ Evalute absolute value }
function FuncAbs(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(ResStr(SIncorFuncParam),[tokABS]);
  Result := Abs(Sender.Pop);
end;

end.