(*
 Moduł do obliczania wyrażeń matematycznych za pomocą tzw."stacji rozrządowej"
 By Patryk Wychowaniec (patryk432@onet.eu)

 Wersja 0.4
*)
Unit ExpressionUnit;

 Interface
 Uses Classes, Dialogs, SysUtils, Math, Windows;
 Const ERROR_OK                 = 0;
       ERROR_TOO_MANY_BRACKETS  = 1;
       ERROR_TOO_FEW_BRACKETS   = 2;
       ERROR_INVALID_FUNCTION   = 3;
       ERROR_INVALID_FUNC_PARAM = 4;
       ERROR_WRONG_OPERATORS    = 5;

 Type TParam = Array of Extended;
 Type TExecute = Function (Param: TParam): Extended;

 Type TFunction = Record
                   Name   : String;
                   Param  : Integer;
                   Execute: TExecute;
                  End;

 Type TExpressionParser = Class
                           Private
                            List     : TStringList;
                            Functions: Array of TFunction;

                            Function ParseFunction(Num: Integer): Extended;

                            Function PopInt: Extended;
                            Function PeekInt: Extended;
                            Procedure PushInt(Int: Extended);

                            Function PopStr: String;
                            Function PeekStr: String;
                            Procedure PushStr(Str: String);

                            Procedure ClearError;
                            Procedure SetError(Code, Info: Integer; Str: String);

                            Function GetFunctionNum(Str: String): Integer;
                            Function isFunction(Str: String): Boolean;
                           Public
                            ErrorCode, ErrorInfo: Integer;
                            ErrorString         : String;
                            RPN                 : String;

                            Constructor Create;

                            Function ExprToRPN(Expr: String): String;
                            Function EvalRPN: Extended;
                            Function EvalExpr(Expr: String): Extended;

                            Procedure AddFunction(Name: String; Param: Integer; Execute: TExecute);
                          End;

 Implementation
Const Numbers       = ['0'..'9', '.'];
      Operations    = ['+', '-', '*', '/', '%', '^', '>', '<'];
      OperStr       = '+-*/%^';
      NumbStr       = '0123456789';
      Accepted      = ['a'..'z','A'..'Z'];

(* ====== Domyślne dostępne funkcje ====== *)

Function f_SQRT(Param: TParam): Extended;
Begin
 Result := sqrt(Param[0]);
End;

Function f_SIN(Param: TParam): Extended;
Begin
 Result := sin(Param[0]);
End;

Function f_COS(Param: TParam): Extended;
Begin
 Result := cos(Param[0]);
End;

Function f_TAN(Param: TParam): Extended;
Begin
 Result := tan(Param[0]);
End;

Function f_ASIN(Param: TParam): Extended;
Begin
 Result := arcsin(Param[0]);
End;

Function f_ACOS(Param: TParam): Extended;
Begin
 Result := arccos(Param[0]);
End;

Function f_ATAN(Param: TParam): Extended;
Begin
 Result := arctan(Param[0]);
End;

Function f_MIN(Param: TParam): Extended;
Begin
 Result := min(Param[0], Param[1]);
End;

Function f_MAX(Param: TParam): Extended;
Begin
 Result := max(Param[0], Param[1]);
End;

Function f_NWW(Param: TParam): Extended;

  Function NWW(A, B: Integer): Integer;
  Var Dz: Integer;
  Begin
   Dz := 1;
   While (Dz*A mod B <> 0) Do
    Inc(Dz);
   Result := Dz*A;
  End;

Begin
 Result := NWW(round(Param[0]), round(Param[1]));
End;

Function f_NWD(Param: TParam): Extended;

  Function NWD(A, B: Integer): Integer;
  Var Param: TParam;
  Begin
   SetLength(Param, 2);
   Param[0] := A;
   Param[1] := B;
   Result   := (A*B) div round(f_NWW(Param));
  End;

Begin
 Result := NWD(round(Param[0]), round(Param[1]));
End;

Function f_SQR(Param: TParam): Extended;
Begin
 Result := sqr(Param[0]);
End;

Function f_ROUND(Param: TParam): Extended;
Begin
 Result := round(Param[0]);
End;

Function f_PI(Param: TParam): Extended;
Begin
 Result := PI;
End;

Function f_ABS(Param: TParam): Extended;
Begin
 Result := abs(Param[0]);
End;


(* ====== Do parsera ====== *)

Function GetOrder(E: String): Integer;
Const Order: Array[0..2] of Array[0..1] of Char =
(
 ('+', '-'),
 ('*', '/'),
 ('^', '^')
);
Var I, Q: Integer;
Begin
 Result := -1;
 For I := Low(Order) To High(Order) Do
  For Q := Low(Order[I]) To High(Order[I]) Do
   if (Order[I][Q] = E) Then
   Begin
    Result := I;
    Exit;
   End;
End;

Function isNumber(Str: String): Boolean;
Const Numbers = ['0'..'9', '.'];
Var I: Integer;
Begin
 Result := False;
 if (Length(Str) = 0) Then
  Exit;
 Result := True;
 For I := 1 To Length(Str) Do
  if not (Str[I] in Numbers) Then
   Result := False;
End;

(* ===== PARSER ===== *)

Constructor TExpressionParser.Create;
Begin
 List := TStringList.Create;

 //sin,cos,tan,asin,acos,atan,min,max,nww,nwd,sqr,round,pi,abs
 AddFunction('sqrt' , 1, @f_SQRT);
 AddFunction('sin'  , 1, @f_SIN);
 AddFunction('cos'  , 1, @f_COS);
 AddFunction('asin' , 1, @f_ASIN);
 AddFunction('acos' , 1, @f_ACOS);
 AddFunction('atan' , 1, @f_ATAN);
 AddFunction('min'  , 2, @f_MIN);
 AddFunction('max'  , 2, @f_MAX);
 AddFunction('nww'  , 2, @f_NWW);
 AddFunction('nwd'  , 2, @f_NWD);
 AddFunction('sqr'  , 1, @f_SQR);
 AddFunction('round', 1, @f_ROUND);
 AddFunction('pi'   , 0, @f_PI);
 AddFunction('abs'  , 1, @f_ABS);
End;


Function TExpressionParser.GetFunctionNum(Str: String): Integer;
Var I: Integer;
Begin
 Result := -1;
 Str    := LowerCase(Str);
 For I := Low(Functions) To High(Functions) Do
  if (Functions[I].Name = Str) Then
  Begin
   Result := I;
   Exit;
  End;
End;

Function TExpressionParser.isFunction(Str: String): Boolean;
Begin
 Result := GetFunctionNum(Str) <> -1;
End;

Function TExpressionParser.PopInt: Extended;
Begin
 Result := 0;

 if (List.Count = 0) Then
  Exit;

 Result := PeekInt;
 List.Delete(List.Count-1);
End;

Function TExpressionParser.PeekInt: Extended;
Begin
 Result := 0;

 if (List.Count = 0) Then
  Exit;

 Result := StrToFloat(List[List.Count-1]);
End;

Function TExpressionParser.PopStr: String;
Begin
 if (List.Count = 0) Then
  Exit;

 Result := PeekStr;
 List.Delete(List.Count-1);
End;

Function TExpressionParser.PeekStr: String;
Begin
 Result := '';
 if (List.Count = 0) Then
  Exit;
 Result := List[List.Count-1];
End;

Procedure TExpressionParser.PushInt(Int: Extended);
Begin
 List.Add(FloatToStr(Int));
End;

Procedure TExpressionParser.PushStr(Str: String);
Begin
 List.Add(Str);
End;

Function TExpressionParser.ParseFunction(Num: Integer): Extended;
Var Param: TParam;
    I    : Integer;
Begin
 Result := 0;
 if (Num = -1) Then
  Exit;
 SetLength(Param, Functions[Num].Param);
 For I := 0 To Functions[Num].Param-1 Do
 Begin
  if (List.Count = 0) Then
  Begin
   SetError(ERROR_INVALID_FUNC_PARAM, Functions[Num].Param, Functions[Num].Name);
   Exit;
  End;
  Param[I] := PopInt;
 End;

 Result := Functions[Num].Execute(Param);
End;

Function TExpressionParser.ExprToRPN(Expr: String): String;
Var Pos, I : Integer;
    Ex     : Char;
    Str    : String;
    Tmp    : String;
    Func   : String;
    Step   : String;
    Bracket: Integer;

    Function ReadNumber: Extended;
    Var Num: String;
    Begin
     Num := '';
     While (Expr[Pos] in Numbers) Do
     Begin
      Num := Num+Expr[Pos];
      Inc(Pos);
     End;
     Result := StrToFloat(Num);
    End;

Begin
 ClearError;
 DecimalSeparator := '.';
 ErrorCode        := 0;
 List.Clear;
 Expr := Trim(Expr);

 if (Expr = '') Then
  Expr := '0';

 if (Expr[1] = '-') Then
  Insert('0', Expr, 1);

 Expr := StringReplace(Expr, '(-', '(0-', [rfReplaceAll]);

 For I := 1 To Length(NumbStr) Do
  Expr := StringReplace(Expr, NumbStr[I]+'(', NumbStr[I]+'*(', [rfReplaceAll]);

 For I := 1 To Length(OperStr) Do
  Expr := StringReplace(Expr, OperStr[I]+'*', OperStr[I], [rfReplaceAll]);

 if (Expr[1] = '*') Then
  Delete(Expr, 1, 1);

 Result  := '';
 Pos     := 1;
 Step    := Expr;
 Bracket := 0;
 Func    := '';
 Tmp     := '';
 While (true) Do
 Begin
  if (Expr[Pos] in Numbers) Then
   Result := Result+FloatToStr(ReadNumber)+' ';

  if (Expr[Pos] in Operations) Then
  Begin
   if (Expr[Pos-1] in Operations) Then
   Begin
    SetError(ERROR_WRONG_OPERATORS, Pos, Expr[Pos-2]+Expr[Pos-1]+Expr[Pos]+Expr[Pos+1]);
    Exit;
   End;
   Ex := Expr[Pos];
   if (PeekStr <> #0) Then
    if (GetOrder(Ex) <= GetOrder(PeekStr)) Then
     Repeat
      Str := PeekStr;
      if (GetOrder(Ex) <= GetOrder(Str)) Then
      Begin
       Str    := PopStr;
       Result := Result+Str+' ';
      End;
     Until (List.Count = 0) or (GetOrder(Str) < GetOrder(Ex));
   PushStr(Ex);
  End;

  if (Expr[Pos] in Accepted) Then
   Func := Func+Expr[Pos];

  if (Expr[Pos] = '(') Then
  Begin
   if (Func <> '') Then
   Begin
    PushStr(Func);
    Func := '';
   End;
   PushStr('(');
   Inc(Bracket);
  End;

  if (Expr[Pos] = ')') Then
  Begin
   if (Bracket > 0) Then
   Begin
    Repeat
     Str := PopStr;
     if (Str <> '(') Then
      Result := Result+Str+' ';
    Until (List.Count = 0) or (Str = '(');
    if (isFunction(PeekStr)) Then
    Begin
     Tmp    := '';
     Result := Result+PopStr+' ';
    End;
   End;
   Dec(Bracket);
  End;

  if (Pos >= Length(Expr)) Then
   Break;
  Inc(Pos);
 End;

 ErrorInfo := abs(Bracket);

 if (Bracket > 0) Then
  ErrorCode := ERROR_TOO_MANY_BRACKETS;
 if (Bracket < 0) Then
  ErrorCode := ERROR_TOO_FEW_BRACKETS;

 if (ErrorCode <> 0) Then
  Exit;

 Repeat
  Result := Result+PopStr+' ';
 Until (List.Count = 0);

 RPN := Result;
End;

Function TExpressionParser.EvalRPN: Extended;
Var Pos    : Integer;
    Ex     : Char;
    Tmp    : String;
    Func   : String;
    FuncNum: Integer;
    A, B   : Extended;
Begin
 ClearError;
 RPN              := Trim(RPN)+' ';
 DecimalSeparator := '.';
 Result           := 0;
 if (RPN = '') Then
  Exit;
 List.Clear;
 Pos  := 1;
 Tmp  := '';
 Func := '';
 While (true) Do
 Begin
  Ex := RPN[Pos];
  if (Ex in Numbers) Then
  Begin
   Tmp := Tmp+Ex;
  End Else
  if (Ex in Accepted) Then
  Begin
   Func := Func+Ex;
  End Else
  Begin
   if (isNumber(Tmp)) Then
    PushInt(StrToFloat(Tmp));
   FuncNum := -1;
   if (Func <> '') Then
    if (not isFunction(Func)) Then
    Begin
     SetError(ERROR_INVALID_FUNCTION, 0, Func);
     Exit;
    End Else
     FuncNum := GetFunctionNum(Func);
   if (Ex in Operations) Then
   Begin
    B := PopInt;
    A := PopInt;
    Case Ex Of
     '+': PushInt(A+B);
     '-': PushInt(A-B);
     '*': PushInt(A*B);
     '/': PushInt(A/B);
     '%': PushInt(A-B*Floor(A/B));
     '^': PushInt(Power(A, B));
    End;
   End Else
   if (FuncNum > -1) Then
   Begin
    PushInt(ParseFunction(FuncNum));
    if (ErrorCode <> 0) Then
    Begin
     ErrorString := Functions[FuncNum].Name;
     Exit;
    End;
   End;
   Tmp  := '';
   Func := '';
  End;
  Inc(Pos);
  if (Pos > Length(RPN)) Then
   Break;
 End;
 Result := PopInt;
End;

Function TExpressionParser.EvalExpr(Expr: String): Extended;
Var RPNTemp: String;
Begin
 RPNTemp := RPN;
 RPN     := ExprToRPN(Expr);
 if (ErrorCode <> 0) Then
 Begin
  Result := 0;
  Exit;
 End;
 Result  := EvalRPN;
 RPN     := RPNTemp;
End;

Procedure TExpressionParser.ClearError;
Begin
 SetError(ERROR_OK, 0, '');
End;

Procedure TExpressionParser.SetError(Code, Info: Integer; Str: String);
Begin
 ErrorCode   := Code;
 ErrorInfo   := Info;
 ErrorString := Str;
End;

Procedure TExpressionParser.AddFunction(Name: String; Param: Integer; Execute: TExecute);
Var I: Integer;
Begin
 SetLength(Functions, High(Functions)+2);
 I                    := High(Functions);
 Functions[I].Name    := LowerCase(Name);
 Functions[I].Param   := Param;
 Functions[I].Execute := Execute;
End;
End.