unit FunctionString;

interface

function FunctionToReal(s: string): real;
function FunctionToString(s: string): string;
function MsgError: string;

implementation

uses
   SysUtils;

type
   TFunction = record
      Name: string;
      ParametrCount: byte;
   end;

var
   ListFunction: array of TFunction;
   Line, ErrorStr: string;
   Lp, ErrorFunction: integer;
   NextChar: char;

function xAbs(x: real): real;
begin
   Result:=Abs(x);
end;

function xRound(x: real): real;
begin
   Result:=Round(x);
end;

function xTrunc(x: real): real;
begin
   Result:=Trunc(x);
end;

function xFrac(x: real): real;
begin
   Result:=Frac(x);
end;

function xPower(Base, Exponent: real): real;

   function IntPower(Base: real; Exponent: integer): real;
   var i: integer;
   begin
      Result:=Base;
      for i:=2 to Abs(Exponent) do
         Result:=Result*Base;
      if Exponent<0 then
         Result:=1/Result;
   end;

begin
   if Exponent=0 then // a^0 = 1
      Result:=1 else
   if Base=0 then // 0^n = 0
      Result:=0 else
   if Frac(Exponent)=0 then // a^n.0 = a^n
      Result:=IntPower(Base, Trunc(Exponent)) else
   if Base>0 then
      Result:=Exp(Exponent*Ln(Base)) else
   begin
      ErrorFunction:=4;
      ErrorStr:=Format('Возведение числа %g в степень %g невозможно',
         [Base, Exponent]);
      Result:=0;
   end;
end;

function xSqr(x: real): real;
begin
   Result:=Sqr(x);
end;

function xSqrt(x: real): real;
begin
   if x>=0 then
      Result:=Sqrt(x) else
   begin
      ErrorFunction:=5;
      ErrorStr:=Format('Корень отрицательного числа %g не существует', [x]);
      Result:=0;
   end;
end;

function xExp(x: real): real;
begin
   Result:=Exp(x);
end;

function xLn(x: real): real;
begin
   if x>0 then
      Result:=Ln(x) else
   begin
      ErrorFunction:=6;
      ErrorStr:=Format('Натуральный логарифм числа %g не существует', [x]);
      Result:=0;
   end;
end;

function xLog10(x: real): real;
begin
   if x>0 then
      Result:=Ln(x)/Ln(10) else
   begin
      ErrorFunction:=7;
      ErrorStr:=Format('Десятичный логарифм числа %g не существует', [x]);
      Result:=0;
   end;
end;

function xLogN(Base, x: real): real;
begin
   if (x>0) and (Base>0) and (Base<>1) then
      Result:=Ln(x)/Ln(Base) else
   begin
      ErrorFunction:=8;
      ErrorStr:=Format('Логарифм числа %g по основанию %g не существует',
         [x, Base]);
      Result:=0;
   end;
end;

function xPi: real;
begin
   Result:=Pi;
end;

function xSin(x: real): real;
begin
   Result:=Sin(x);
end;

function xCos(x: real): real;
begin
   Result:=Cos(x);
end;

function xTan(x: real): real;
begin
   if Cos(x)<>0 then
      Result:=Sin(x)/Cos(x) else
   begin
      ErrorFunction:=9;
      ErrorStr:=Format('Тангенс числа %g бесконечен', [x]);
      Result:=0;
   end;
end;

function xCoTan(x: real): real;
begin
   if Sin(x)<>0 then
      Result:=Cos(x)/Sin(x) else
   begin
      ErrorFunction:=10;
      ErrorStr:=Format('Котангенс числа %g бесконечен', [x]);
      Result:=0;
   end;
end;

function xMin(x: array of real): real;
var i: integer;
begin
   if Integer(High(x))<Integer(Low(x)) then
   begin
      ErrorFunction:=11;
      Result:=0;
      Exit;
   end;
   Result:=x[Low(x)];
   for i:=Low(x)+1 to High(x) do
      if Result>x[i] then
         Result:=x[i];
end;

function xMax(x: array of real): real;
var i: integer;
begin
   if Integer(High(x))<Integer(Low(x)) then
   begin
      ErrorFunction:=11;
      Result:=0;
      Exit;
   end;
   Result:=x[Low(x)];
   for i:=Low(x)+1 to High(x) do
      if Result<x[i] then
         Result:=x[i];
end;

{ ---------------------------------------------------------------------------- }

procedure NewChar_; // следующий символ, включая пробел
begin
   if Lp<Length(Line) then
      Inc(Lp);
   NextChar:=UpCase(Line[Lp]);
end;

procedure NewChar; // следующий символ, игнорируя пробел
begin
   repeat
      NewChar_;
   until NextChar<>' ';
end;

function ValAdd: real; forward;

function ValNum: real; // число
var s: string;
    err: integer;
begin
   { коррекция: '.678' = '0.678' }
   if NextChar='.' then
      s:='0' else
      s:='';
   { вывод числа }
   while NextChar in ['0'..'9', '.', 'E'] do
   begin
      s:=s+NextChar;
      { проверка на 1E+1 }
      if NextChar='E' then
      begin
         { коррекция: '2.E4' = '2.0E4' }
         if s[Length(s)-1]='.' then
            Insert('0', s, Length(s));
         NewChar_;
         if NextChar in ['+', '-'] then
         begin
            s:=s+NextChar;
            NewChar_;
         end;
      end else
         NewChar_;
   end;
   { удаление пробела после числа }
   if Line[Lp]=' ' then
      NewChar;
   { коррекция: '25.' = '25.0' }
   if s[Length(s)]='.' then
      s:=s+'0';
   Val(s, Result, err);
   if err<>0 then
   begin
      ErrorFunction:=2;
      ErrorStr:=s;
   end;
   if ErrorFunction<>0 then
      Result:=0;
end;

function ValCase: real; // число, функция
var fErr: boolean;
    s: string;
    i, cx: integer;
    a, b: real;
    x:array of real;
begin
   Result:=0;
   case NextChar of
   '+':
   begin
      NewChar;
      Result:=ValCase;
   end;
   '-':
   begin
      NewChar;
      Result:=-ValCase;
   end;
   '0'..'9', '.':
      Result:=ValNum;
   'A'..'Z':
   begin
      s:='';
      { набор слова-функции }
      while NextChar in ['0'..'9', '_', 'A'..'Z'] do
      begin
         s:=s+NextChar;
         NewChar_;
      end;
      { пропуск пробелов }
      if NextChar=' ' then
         NewChar;
      fErr:=true;
      { проверка на существование функции }
      for i:=Low(ListFunction) to High(ListFunction) do
         with ListFunction[i] do
            if Name=s then // найдена функция в списке
            begin
               fErr:=false;
               a:=0;
               b:=0;
               cx:=0;
               SetLength(x, cx);
               if NextChar='(' then
                  case ParametrCount of
                  0: // например, PI или PI()
                  begin
                     NewChar;
                     if NextChar<>')' then // например, PI(5)
                     begin
                        ErrorFunction:=15;
                        ErrorStr:=s;
                     end;
                     NewChar;
                  end;
                  1: // например, Abs(-4.1)
                  begin
                     NewChar;
                     if NextChar=')' then // например, Abs()
                     begin
                        ErrorFunction:=16;
                        ErrorStr:=s;
                     end else
                        a:=ValAdd; //вычисление параметра
                     if (ErrorFunction=0) and (NextChar<>')') then
                        // например, Abs(-4.1, 6)
                     begin
                        ErrorFunction:=16;
                        ErrorStr:=s;
                     end;
                     NewChar;
                  end;
                  2: // например, Power(2, 3)
                  begin
                     NewChar;
                     if NextChar=')' then // например, Power()
                     begin
                        ErrorFunction:=17;
                        ErrorStr:=s;
                     end else
                        a:=ValAdd; // вычисление 1-го параметра
                     if (ErrorFunction=0) and (NextChar<>',') then
                     // например, Power(2)
                     begin
                        ErrorFunction:=17;
                        ErrorStr:=s;
                     end;
                     NewChar;
                     if ErrorFunction=0 then
                        b:=ValAdd; // вычисление 2-го параметра
                     if (ErrorFunction=0) and (NextChar<>')') then
                     // например, Power(2, 3, 7)
                     begin
                        ErrorFunction:=17;
                        ErrorStr:=s;
                     end;
                     NewChar;
                  end;
                  3: // например, Min(8, 4, 5)
                  begin
                     NewChar;
                     { после открывающейся скобки должен быть следующий символ }
                     if NextChar in ['0'..'9', '+', '-', '.', ')'] then
                        { работать до закрывающейся скобки }
                        while (ErrorFunction=0) and (NextChar<>')') do
                        begin
                           { вычисляем параметры через запятую }
                           Inc(cx);
                           SetLength(x, cx);
                           x[cx-1]:=ValAdd; // вычисление очередного параметра
                           { после параметра должна быть запятая или скобка }
                           if (ErrorFunction in [0, 12]) and
                              not (NextChar in [',', ')']) then
                              // например, Min(2, 3; 7)
                           begin
                              ErrorFunction:=18;
                              ErrorStr:=s;
                           end;
                           if NextChar=')' then // если встретилась скобка,
                              Break else // то выход из цикла While,
                              NewChar; // иначе чтение следующего символа
                        end else
                     begin
                        ErrorFunction:=18;
                        ErrorStr:=s;
                     end;
                     NewChar;
                  end;
                  end{Case} else
                  if ParametrCount>0 then // например, PI без скобок
                     ErrorFunction:=12;
               { вычисление очередной функции }      
               if ErrorFunction=0 then
               begin
                  if Name='ABS' then
                     Result:=xAbs(a);
                  if Name='ROUND' then
                     Result:=xRound(a);
                  if Name='TRUNC' then
                     Result:=xTrunc(a);
                  if Name='FRAC' then
                     Result:=xFrac(a);
                  if Name='POWER' then
                     Result:=xPower(a, b);
                  if Name='SQR' then
                     Result:=xSqr(a);
                  if Name='SQRT' then
                     Result:=xSqrt(a);
                  if Name='EXP' then
                     Result:=xExp(a);
                  if Name='LN' then
                     Result:=xLn(a);
                  if Name='LOG10' then
                     Result:=xLog10(a);
                  if Name='LOGN' then
                     Result:=xLogN(a, b);
                  if Name='PI' then
                     Result:=xPi;
                  if Name='SIN' then
                     Result:=xSin(a);
                  if Name='COS' then
                     Result:=xCos(a);
                  if Name='TAN' then
                     Result:=xTan(a);
                  if Name='COTAN' then
                     Result:=xCoTan(a);
                  if Name='MIN' then
                     Result:=xMin(x);
                  if Name='MAX' then
                     Result:=xMax(x);
               end; 
            end;
      if fErr then
      begin
         ErrorFunction:=19;
         ErrorStr:=s;
      end;
   end;
   '(': // например, (2+3)
   begin
      NewChar;
      Result:=ValAdd;
      if (ErrorFunction=0) and (NextChar<>')') then
         ErrorFunction:=13;
      NewChar;
   end;
   else
      ErrorFunction:=12;
   end;
   If ErrorFunction<>0 then
      Result:=0;
end;

function ValPower: real; // степенная форма числа
var r: real;
begin
   Result:=ValCase;
   while (ErrorFunction=0) and (NextChar='^') do
   begin
      NewChar;
      r:=ValCase;
      Result:=xPower(Result, r);
   end;
   if ErrorFunction<>0 then
      Result:=0;
end;

function ValMul: real; // умножение или деление чисел
var r: real;
    c: char;
begin
   Result:=ValPower;
   while (ErrorFunction=0) and (NextChar in ['*', '/']) do
   begin
      c:=NextChar;
      NewChar;
      r:=ValPower;
      if ErrorFunction=0 then
         case c of
         '*': Result:=Result*r;
         '/': if r<>0 then
                 Result:=Result/r else
                 ErrorFunction:=14;
         end else
         Result:=0;
   end;
   if ErrorFunction<>0 then
      Result:=0;
end;

function ValAdd: real; // сложение или вычитание чисел
var r: real;
    c: char;
begin
   Result:=ValMul;
   while (ErrorFunction=0) and (NextChar in ['+', '-']) do
   begin
      c:=NextChar;
      NewChar;
      r:=ValMul;
      if ErrorFunction=0 then
         case c of
         '+': Result:=Result+r;
         '-': Result:=Result-r;
         end else
         Result:=0;
   end;
   if (ErrorFunction=0) and not (NextChar in [#0, ')', ',']) then
      ErrorFunction:=12;
   if ErrorFunction<>0 then
      Result:=0;
end;

function FunctionToReal(s: string): real;
var i, h: integer;
begin
   Result:=0;
   ErrorFunction:=0;
   ErrorStr:='';
   h:=0;
   { проверка на количество скобок }
   for i:=1 to Length(s) do
      case s[i] of
      '(': Inc(h);
      ')': Dec(h);
      end;
   { кол-во открывающихся скобок = кол-ву закрывающихся }
   if h=0 then
   begin
      Lp:=0;
      Line:=s+#0;
      NewChar;
      { проверка на пустую строку }
      if NextChar<>#0 then
      begin
         Result:=ValAdd;
         if (ErrorFunction=0) and (NextChar<>#0) then
            ErrorFunction:=12;
      end else
         ErrorFunction:=1;
   end else
   begin
      ErrorFunction:=3;
      if h>0 then
         ErrorStr:='Количество открывающихся скобок больше закрывающихся на '+
            IntToStr(h) else
         ErrorStr:='Количество закрывающихся скобок больше открывающихся на '+
            IntToStr(-h);
   end;
   if ErrorFunction<>0 then
      Result:=0;
end;

function FunctionToString(s: string): string;
begin
   Result:=FloatToStr(FunctionToReal(s));
   if ErrorFunction>0 then
      Result:=MsgError;
end;

function MsgError: string;
begin
   case ErrorFunction of
   0: Result:='Корректный результат';
   1: Result:='Пустая строка (или не введена формула)';
   2: Result:='Неверно введено число: '+ErrorStr;
   3..10: Result:=ErrorStr;
   11: Result:='Нулевой массив';
   12: Result:='Неправильная запись формулы'; // общая ошибка
   13: Result:='Неправильное расположение скобок'; // например: Max(4, (5, 2))
   14: Result:='Деление на ноль';
   15: Result:=Format('Функция ''%s'' не должна иметь параметры', [ErrorStr]);
   16: Result:=Format('Функция ''%s'' должна иметь 1 параметр', [ErrorStr]);
   17: Result:=Format('Функция ''%s'' должна иметь 2 параметра', [ErrorStr]);
   18: Result:=Format('Функция ''%s'' содержит неизвестные параметры', [ErrorStr]);
   19: Result:='Программа не распознает функцию: '+ErrorStr;
   else
      Result:='Неизвестная ошибка';
   end;
end;

procedure AddFunction(aName: string; aParametrCount: byte);
var len: integer;
begin
   len:=High(ListFunction)+2;
   SetLength(ListFunction, len);
   with ListFunction[len-1] do
   begin
      Name:=aName;
      ParametrCount:=aParametrCount;
   end;
end;

begin
   SetLength(ListFunction, 0);
   AddFunction('ABS', 1);
   AddFunction('ROUND', 1);
   AddFunction('TRUNC', 1);
   AddFunction('FRAC', 1);
   AddFunction('POWER', 2);
   AddFunction('SQR', 1);
   AddFunction('SQRT', 1);
   AddFunction('EXP', 1);
   AddFunction('LN', 1);
   AddFunction('LOG10', 1);
   AddFunction('LOGN', 2);
   AddFunction('PI', 0);
   AddFunction('SIN', 1);
   AddFunction('COS', 1);
   AddFunction('TAN', 1);
   AddFunction('COTAN', 1);
   AddFunction('MIN', 3);
   AddFunction('MAX', 3);
   { Конечно, это не весь перечень математических функций, но можно и еще      }
   { добавить. Для этого описать новую функцию, определить ее параметры, в     }
   { функции ValCase добавить адрес, и зарегистирировать функцией AddFunction. }
end.