(*
 Moduł do obliczania wyrażeń matematycznych za pomocą tzw."stacji rozrządowej"
 By Patryk Wychowaniec (patryk432@onet.eu)
*)
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;
       ERROR_STACK_FAIL         = 6;

 Type TExpressionParser = Class
                           Private
                            ErrorCode, ErrorInfo: Integer;
                            ErrorString         : String;
                            RPN                 : String;
                            List                : TStringList;

                            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);
                           Public
                            Constructor Create;

                            Function ExprToRPN(Expr: String): String;
                            Function GetRPN: String;
                            Procedure SetRPN(Expr: String);

                            Function EvalRPN: Extended;

                            Function EvalExpr(Expr: String): Extended;
                          End;

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

      f_SQRT        = 0;
      f_SIN         = 1;
      f_COS         = 2;
      f_TAN         = 3;
      f_ASIN        = 4;
      f_ACOS        = 5;
      f_ATAN        = 6;
      f_MIN         = 7;
      f_MAX         = 8;
      f_NWW         = 9;
      f_NWD         = 10;
      f_SQR         = 11;
      f_ROUND       = 12;
      f_PI          = 13;
      f_ABS         = 14;

      Functions     : Array[0..014] of String                = ('sqrt', 'sin', 'cos', 'tan', 'asin', 'acos', 'atan', 'min', 'max', 'nww', 'nwd', 'sqr', 'round', 'pi', 'abs');
      FunctionsParam: Array[0..High(Functions)] of Integer   = (1,      1,     1,     1,     1,      1,      1,      2,     2,     2,     2,     1,     1,       0,    1);

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;

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

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

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;

Function NWD(A, B: Integer): Integer;
Begin
 Result := (A*B) div NWD(A,B);
End;


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

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

Function TExpressionParser.PopInt: Extended;
Begin
 if (List.Count = 0) Then
 Begin
  Result    := 0;
  ErrorCode := ERROR_STACK_FAIL;
  Exit;
 End;

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

Function TExpressionParser.PeekInt: Extended;
Begin
 if (List.Count = 0) Then
 Begin
  Result    := 0;
  ErrorCode := ERROR_STACK_FAIL;
  Exit;
 End;

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

Function TExpressionParser.PopStr: String;
Begin
 if (List.Count = 0) Then
 Begin
  Result    := '';
  ErrorCode := ERROR_STACK_FAIL;
  Exit;
 End;

 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: Array of Extended;
    I    : Integer;
Begin
 Result := 0;
 if (Num = -1) Then
  Exit;
 SetLength(Param, FunctionsParam[Num]);
 For I := 0 To FunctionsParam[Num]-1 Do
 Begin
  if (List.Count = 0) Then
  Begin
   ErrorCode := ERROR_INVALID_FUNC_PARAM;
   ErrorInfo := FunctionsParam[Num];
   Exit;
  End;
  Param[I] := PopInt;
 End;

 Case Num Of
  f_SQRT : Result := sqrt(Param[0]);
  f_SIN  : Result := sin(Param[0]);
  f_COS  : Result := cos(Param[0]);
  f_TAN  : Result := tan(Param[0]);
  f_ASIN : Result := arcsin(Param[0]);
  f_ACOS : Result := arccos(Param[0]);
  f_ATAN : Result := arctan(Param[0]);
  f_MIN  : Result := min(Param[0], Param[1]);
  f_MAX  : Result := max(Param[0], Param[1]);
  f_NWW  : Result := NWW(Round(Param[0]), Round(Param[1]));
  f_NWD  : Result := NWD(Round(Param[0]), Round(Param[1]));
  f_ROUND: Result := Round(Param[0]);
  f_PI   : Result := PI;
  f_ABS  : Result := abs(Param[0]);
 End;
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
 ErrorCode := 0;
 List.Clear;
 Expr := Trim(Expr);

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

 ErrorCode := ERROR_OK;
 ErrorInfo := 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
    ErrorCode := ERROR_WRONG_OPERATORS;
    ErrorInfo := Pos;
    Result    := 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.GetRPN: String;
Begin
 Result := RPN;
End;

Procedure TExpressionParser.SetRPN(Expr: String);
Begin
 RPN := Expr;
End;

Function TExpressionParser.EvalRPN: Extended;
Var Pos    : Integer;
    Ex     : Char;
    Tmp    : String;
    Func   : String;
    FuncNum: Integer;
    A, B   : Extended;
Begin
 ErrorCode := 0;
 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
     ErrorCode   := ERROR_INVALID_FUNCTION;
     ErrorString := 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];
     Exit;
    End;
   End;
   Tmp  := '';
   Func := '';
  End;
  Inc(Pos);
  if (Pos > Length(RPN)) Then
   Break;
 End;
 Result := PopInt;
End;

Function TExpressionParser.EvalExpr(Expr: String): Extended;
Begin
 ExprToRPN(Expr);
 Result := EvalRPN;
End;
End.