{******************************************************************
*  (c)copyrights Capella Development Group, Donetsk 1999 - 2000
*  Project: Zeos Library
*  Module: Formula parser component
*  Author: Sergey Seroukhov   E-Mail: voland@kita.dgtu.donetsk.ua
*  Date: 26/03/99
*
*  List of changes:
*   27/03/99 - Class convert to component, add vars
*   16/04/99 - Add some functions, operators LIKE, XOR
*   23/04/99 - Add math functions
*     Fixed error in CheckParams method
*     Fixed Variable processing bug
*   13/11/99 - Add string resource
*   13/03/00 - Fixed style (Thanks Robert Marquardt)
******************************************************************}

unit ZParser;

{$R *.DCR}

interface

uses SysUtils, Classes, ZToken, ZMatch, Math;

{$INCLUDE Zeos.inc}

const
  MAX_PARSE_ITEMS = 100;
  MAX_PARSE_STACK = 100;
  MAX_PARSE_VARS  = 20;
  MAX_PARSE_FUNCS = 20;

type

  TParseItemType=(ptFunction, ptVariable, ptDelim, ptString, ptInteger, ptFloat,
    ptBoolean);

  TParseItem = record
    ItemValue: Variant;
    ItemType:  TParseItemType;
  end;

  TParseStack = array[0..MAX_PARSE_STACK] of Variant;

  TParseVar = record
    VarName:  string;
    VarValue: Variant;
  end;

  TZParser = class;

  TParseFunc = function(Sender: TZParser): Variant;

  TParseFuncRec = record
    FuncName: string;
    FuncPtr: TParseFunc;
  end;

  EParseException = class(Exception);

{*************** TZParser implementation *************}

  TZParser = class(TComponent)
  private
    FParseItems: array[0..MAX_PARSE_ITEMS] of TParseItem;
    FParseCount: Integer;
    FErrCheck:   Integer;
    FEquation:   string;
    FParseStack: TParseStack;
    FStackCount: Integer;
    FVars:       array[0..MAX_PARSE_VARS] of TParseVar;
    FVarCount:   Integer;
    FFuncs:      array[0..MAX_PARSE_FUNCS] of TParseFuncRec;
    FFuncCount:  Integer;

    function  ExtractTokenEx(var Buffer, Token: string): TParseItemType;
    function  OpLevel(Operat: string): Integer;
    function  Parse(Level: Integer; var Buffer: string): Integer;
    procedure SetEquation(Value: string);
    function  GetVar(VarName: string): Variant;
    procedure SetVar(VarName: string; VarValue: Variant);
    function  GetVarName(VarIndex: Integer): string;
    function  GetFunc(FuncName: string): TParseFunc;
    procedure SetFunc(FuncName: string; FuncPtr: TParseFunc);
    function  GetFuncName(FuncIndex: Integer): string;
    procedure CheckTypes(Value1: Variant; var Value2: Variant);
    function  ConvType(Value: Variant): Variant;
    function  CheckFunc(var Buffer: string): Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function  Evalute: Variant;
    procedure Clear;
    procedure Push(Value: Variant);
    function  Pop: Variant;

    property Variables[Index: string]: Variant read GetVar  write SetVar;
    property VarCount: Integer read FVarCount;
    property VarNames[Index: Integer]: string read GetVarName;
    property Functions[Index: string]: TParseFunc read GetFunc write SetFunc;
    property FuncCount: Integer read FFuncCount;
    property FuncNames[Index: Integer]: string read GetFuncName;
  published
    property Equation: string read FEquation write SetEquation;
  end;

{ Component registration }
procedure Register;

implementation

uses ZExtra, ZCommonConst, ZVclUtils;

const
  tokABS   = 'ABS';
  tokAND   = 'AND';
  tokCOS   = 'COS';
  tokEXP   = 'EXP';
  tokFALSE = 'FALSE';
  tokIIF   = 'IIF';
  tokLIKE  = 'LIKE';
  tokLN    = 'LN';
  tokMAX   = 'MAX';
  tokMIN   = 'MIN';
  tokNOT   = 'NOT';
  tokNOW   = 'NOW';
  tokOR    = 'OR';
  tokSIN   = 'SIN';
  tokSQRT  = 'SQRT';
  tokSUM   = 'SUM';
  tokTAN   = 'TAN';
  tokTRUE  = 'TRUE';
  tokXOR   = 'XOR';

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

{ Get current date and time }
function FuncNow(Sender: TZParser): Variant; forward;

{ Define minimal value }
function FuncMin(Sender: TZParser): Variant; forward;

{ Define maximum value }
function FuncMax(Sender: TZParser): Variant; forward;

{ Define result by value }
function FuncIIf(Sender: TZParser): Variant; forward;

{ Calculate sum of values }
function FuncSum(Sender: TZParser): Variant; forward;

{ Evalue sinus value }
function FuncSin(Sender: TZParser): Variant; forward;

{ Evalue cosinus value }
function FuncCos(Sender: TZParser): Variant; forward;

{ Evalue tangens value }
function FuncTan(Sender: TZParser): Variant; forward;

{ Evalue exponent value }
function FuncExp(Sender: TZParser): Variant; forward;

{ Evalue natural logoriphm value }
function FuncLn(Sender: TZParser): Variant; forward;

{ Evalue square root value }
function FuncSqrt(Sender: TZParser): Variant; forward;

{ Evalue absolute value }
function FuncAbs(Sender: TZParser): Variant; forward;

{******************* TZParser implementation ****************}

{ Class constructor }
constructor TZParser.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FErrCheck   := 0;
  FStackCount := 0;
  FVarCount   := 0;
  FFuncCount  := 0;
  SetFunc(tokNOW, FuncNow);
  SetFunc(tokMAX, FuncMax);
  SetFunc(tokMIN, FuncMin);
  SetFunc(tokIIF, FuncIIf);
  SetFunc(tokSUM, FuncSum);
  SetFunc(tokSIN, FuncSin);
  SetFunc(tokCOS, FuncCos);
  SetFunc(tokTAN, FuncTan);
  SetFunc(tokEXP, FuncExp);
  SetFunc(tokLN,  FuncLn);
  SetFunc(tokABS, FuncAbs);
  SetFunc(tokSQRT,FuncSqrt);
end;

{ Class destructor }
destructor TZParser.Destroy;
begin
  inherited Destroy;
end;

{ Extract highlevel lexem }
function TZParser.ExtractTokenEx(var Buffer, Token: string): TParseItemType;
var
  P: Integer;
  Temp: string;
  TokenType: TTokenType;
begin
  repeat
    TokenType := ExtractToken(Buffer, Token);
  until (Token <> tokNL) and (Token <> tokCR);
  if Token = '[' then
  begin
    TokenType := ttAlpha;
    P := Pos(']',Buffer);
    Token := '';
    if P > 0 then
    begin
      Token  := Copy(Buffer, 1, P-1);
      Buffer := Copy(Buffer, P+1, Length(Buffer)-P);
    end;
  end;
  if (Buffer <> '') and (Token = '>') and (Buffer[1] = '=') then
  begin
    ExtractToken(Buffer, Temp);
    Token := Token + Temp;
  end;
  if (Buffer <> '') and (Token = '<') and ((Buffer[1] = '=')
    or (Buffer[1] = '>')) then
  begin
    ExtractToken(Buffer, Temp);
    Token := Token + Temp;
  end;
  Temp := UpperCase(Token);
  if (Temp = tokAND) or (Temp = tokNOT) or (Temp = tokOR)
    or (Temp = tokXOR) or (Temp = tokLIKE) then
  begin
    Token  := Temp;
    Result := ptDelim;
    Exit;
  end;
  if (Temp = tokTRUE) or (Temp = tokFALSE) then
  begin
    Token  := Temp;
    Result := ptBoolean;
    Exit;
  end;

  Result := ptString;
  case TokenType of
    ttAlpha:
      Result := ptVariable;
    ttDelim:
      Result := ptDelim;
    ttDigit:
      begin
        if (Buffer <> '') and (Buffer[1] = '.') then
        begin
          ExtractToken(Buffer, Temp);
          Token := Token + '.';
          if (Buffer <> '') and (Buffer[1] >= '0') and (Buffer[1] <= '9') then
          begin
            ExtractToken(Buffer,Temp);
            Token := Token + Temp;
          end;
          Result := ptFloat;
        end else
          Result := ptInteger;
      end;
  end;
end;

{ Get priority level of operation }
function TZParser.OpLevel(Operat: string): Integer;
var
  Temp: string;
begin
  Result := 7;
  Temp := UpperCase(Operat);
  if (Temp = tokAND) or (Temp = tokOR) or (Temp = tokXOR) then
    Result := 1;
  if Temp = tokNOT then
    Result := 2;
  if (Temp = '<') or (Temp = '>') or (Temp = '=') or (Temp = '>=')
    or(Temp = '<=') or (Temp = '<>') then
    Result := 3;
  if (Temp[1] = '+') or (Temp[1] = '-') or (Temp = tokLIKE) then
    Result := 4;
  if (Temp[1] = '/') or (Temp[1] = '*') or (Temp[1] = '%') then
    Result := 5;
  if (Temp[1] = '^') then
    Result := 6;
end;

{ Internal convert equation from infix form to postfix }
function TZParser.Parse(Level: Integer; var Buffer: string): Integer;
var
  ParseType: TParseItemType;
  Token, FuncName: string;
  NewLevel, Params, SaveCount: Integer;
  Temp: Char;
begin
  Result := 0;
  while Buffer <> '' do
  begin
    ParseType := ExtractTokenEx(Buffer, Token);
    if Token = '' then
      Exit;
    if (Token = ')') or (Token = ',') then
    begin
      PutbackToken(Buffer, Token);
      Exit;
    end;
    if Token = '(' then
    begin
      FErrCheck := 0;
      Parse(0,Buffer);
      ExtractTokenEx(Buffer, Token);
      if Token <> ')' then
        raise EParseException.Create(ResStr(SSyntaxError));
      FErrCheck := 1;
      Continue;
    end;

    if ParseType = ptDelim then
    begin
      NewLevel := OpLevel(Token);

      if (FErrCheck = 2) and (Token <> tokNOT) then
        raise EParseException.Create(ResStr(SSyntaxError));
      if FErrCheck = 0 then
        if (Token <> tokNOT) and (Token <> '+') and (Token <> '-') then
          raise EParseException.Create(ResStr(SSyntaxError))
        else if Token <> tokNOT then
          NewLevel := 6;

      if (Token <> tokNOT) and (NewLevel <= Level) then
      begin
        PutbackToken(Buffer, Token);
        Result := NewLevel;
        Exit;
      end else if (Token = tokNOT) and (NewLevel < Level) then
      begin
        PutbackToken(Buffer, Token);
        Result := NewLevel;
        Exit;
      end;

      if (FErrCheck = 0) and (Token = '+') then
        Continue;
      if (FErrCheck = 0) and (Token = '-') then
        Token := '~';
      FErrCheck := 2;

      while (Buffer <> '') and (Buffer[1] <> ')')
        and (Parse(NewLevel, Buffer) > NewLevel) do;
      FParseItems[FParseCount].ItemValue := Token;
      FParseItems[FParseCount].ItemType  := ptDelim;
      Inc(FParseCount);
      Result := NewLevel;
      Continue;
    end;

    if FErrCheck = 1 then
      raise EParseException.Create(ResStr(SSyntaxError));
    FErrCheck := 1;

    case ParseType of
      ptVariable:
        begin
          FParseItems[FParseCount].ItemValue := Token;
          if CheckFunc(Buffer) then
            ParseType := ptFunction
          else
            SetVar(Token, NULL);
        end;
      ptInteger:
        FParseItems[FParseCount].ItemValue := StrToInt(Token);
      ptFloat:
        begin
          Temp := DecimalSeparator;
          DecimalSeparator := '.';
          FParseItems[FParseCount].ItemValue := StrToFloat(Token);
          DecimalSeparator := Temp;
        end;
      ptString:
        begin
          DeleteQuotes(Token);
          FParseItems[FParseCount].ItemValue := Token;
        end;
      ptBoolean:
        FParseItems[FParseCount].ItemValue := (Token = tokTRUE);
    end;

{ Process function params }
    if ParseType = ptFunction then
    begin
      FuncName  := AnsiUpperCase(Token);
      SaveCount := FParseCount;
      Params    := 0;
      repeat
        FErrCheck := 0;
        Parse(0,Buffer);
        ExtractTokenEx(Buffer, Token);
        case Token[1] of
          ',':
            begin
              Inc(Params);
              Continue;
            end;
          ')':
            begin
              if SaveCount < FParseCount then
                Inc(Params);
              FParseItems[FParseCount].ItemValue := ConvType(Params);
              FParseItems[FParseCount].ItemType  := ptInteger;
              Inc(FParseCount);
              Break;
            end;
          else
            raise EParseException.Create(ResStr(SSyntaxError));
        end;
      until Buffer = '';
      FParseItems[FParseCount].ItemValue := FuncName;
    end;

    FParseItems[FParseCount].ItemValue :=
      ConvType(FParseItems[FParseCount].ItemValue);
    FParseItems[FParseCount].ItemType := ParseType;
    Inc(FParseCount);
  end;
end;

{ Split equation to stack }
procedure TZParser.SetEquation(Value: string);
begin
  FParseCount := 0;
  FErrCheck   := 0;
  FEquation   := Value;
//  while Value<>'' do
  Parse(0, Value);
end;

{ Get variable name by it index }
function TZParser.GetVarName(VarIndex: Integer): string;
begin
  if VarIndex >= FVarCount then
    raise EParseException.Create(ResStr(SIncorVarIdx));
  Result := AnsiUpperCase(FVars[VarIndex].VarName);
end;

{ Get variable value }
function TZParser.GetVar(VarName: string): Variant;
var
  I: Integer;
begin
  VarName := AnsiUpperCase(VarName);
  I := 0;