Как вычислить математическое выражение?

Дата: 01.01.2007
Автор: Vit

Вариант 1:

Зачастую пользователь должен ввести что-то типа "1+2/(3*4)" и программа должна разобрать выражение и произвести вычисления. Делается это с помощью рекурсивных функций, которые постеменно разбирают выражение. К счастью не обязательно изобретать велосипед: в бесплатной библиотеке RxLib есть модуль Parsing.pas включающий в себя класс для вычисления математических выражений, библиотеку можно взять на

https://www.rxlib.ru/Downl/Downl.htm

или

https://www.torry.net

Модуль Parsing.pas вполне может работать отдельно и без установки пакета компонент (но в таком случае вам прийдется взять еще несколько inc файлов помимо него).

Автор: Vit

Взято с Vingrad.ru https://forum.vingrad.ru

Вариант 2:

В Delphi нет функции, которая бы позволяла посчитать строку с формулой. Но есть множество способов реализовать это самому. Здесь я привел самый простой из них. Он не очень быстрый, но при нынешних скоростях компьютеров для многих целей он подойдет.

Принцип его заключается в следующем. Сначала строка оптимизируется - выкидываются все пробелы, точки и запятые меняются на установленный разделяющий знак (DecimalSeparator). Все числа и параметры (например, x), содержащиеся в строке "обособляются" символом #. В дальнейшем это позволяет избежать путаницы с экспонентой, минусами и. т. д. Следующий шаг - замена, если нужно, всех параметров на их значения. И, наконец, последний шаг, подсчет получившейся строки. Для этого программа ищет все операции с самым высоким приоритетом (это скобки). Считает их значение, вызывая саму себя (рекурсивная функция), и заменяет скобки и их содержимое на их значение, обособленное #. Дальше она выполняет то же самое для операции с более низким приоритетом и так до сложения с вычитанием.

Каждый шаг выделен в отдельную процедуру. Это позволяет быстрее считать функцию, если она не меняется, а меняются только значения параметров.

Вот модуль с этими методами.

unit Recognition;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Math;

type
  TVar = set of char;

procedure Preparation(var s: String; variables: TVar);
function ChangeVar(s: String; c: char; value: extended): String;
function Recogn(st: String; var Num: extended): boolean;

implementation


procedure Preparation(var s: String; variables: TVar);
const
  operators: set of char = ['+','-','*', '/', '^'];
var
  i: integer;
  figures: set of char;
begin
  figures := ['0','1','2','3','4','5','6','7','8','9', DecimalSeparator] + variables;

// " "
  repeat
    i := pos(' ', s);
    if i <= 0 then break;
    delete(s, i, 1);

  until 1 = 0;

  s := LowerCase(s);

// ".", ","
  if DecimalSeparator = '.' then begin
    i := pos(',', s);
    while i > 0 do begin
      s[i] := '.';
      i := pos(',', s);
    end;
  end else begin
    i := pos('.', s);
    while i > 0 do begin
      s[i] := ',';
      i := pos('.', s);
    end;
  end;

// Pi

  repeat
    i := pos('pi', s);
    if i <= 0 then break;
    delete(s, i, 2);
    insert(FloatToStr(Pi), s, i);
  until 1 = 0;

// ":"
  repeat
    i := pos(':', s);
    if i <= 0 then break;
    s[i] := '/';
  until 1 = 0;

// |...|
  repeat
    i := pos('|', s);
    if i <= 0 then break;
    s[i] := 'a';
    insert('bs(', s, i + 1);
    i := i + 3;

    repeat i := i + 1 until (i > Length(s)) or (s[i] = '|');
    if s[i] = '|' then s[i] := ')';
  until 1 = 0;

// #...#
  i := 1;
  repeat
    if s[i] in figures then begin
      insert('#', s, i);
      i := i + 2;
      while (s[i] in figures) do i := i + 1;
      insert('#', s, i);
      i := i + 1;
    end;
    i := i + 1;
  until i > Length(s);

end;

function ChangeVar(s: String; c: char; value: extended): String;
var
  p: integer;
begin
  result := s;
  repeat
    p := pos(c, result);
    if p <= 0 then break;
    delete(result, p, 1);
    insert(FloatToStr(value), result, p);
  until 1 = 0;
end;

function Recogn(st: String; var Num: extended): boolean;
const
  pogr = 1E-5;
var

  p, p1: integer;
  i, j: integer;
  v1, v2: extended;
  func: (fNone, fSin, fCos, fTg, fCtg, fArcsin, fArccos, fArctg, fArcctg, fAbs, fLn, fLg, fExp);
  Sign: integer;
  s: String;
  s1: String;

  function FindLeftValue(p: integer; var Margin: integer; var Value: extended): boolean;
  var
    i: integer;
  begin
    i := p - 1;
    repeat i := i - 1 until (i <= 0) or (s[i] = '#');

    Margin := i;
    try
      Value := StrToFloat(copy(s, i + 1, p - i - 2));
      result := true;
    except
      result := false
    end;
    delete(s, i, p - i);
  end;

  function FindRightValue(p: integer; var Value: extended): boolean;
  var
    i: integer;
  begin
    i := p + 1;
    repeat i := i + 1 until (i > Length(s)) or (s[i] = '#');
    i := i - 1;
    s1 := copy(s, p + 2, i - p - 1);

    result := TextToFloat(PChar(s1), value, fvExtended);
    delete(s, p + 1, i - p + 1);
  end;

  procedure PutValue(p: integer; NewValue: extended);
  begin
    insert('#' + FloatToStr(v1) + '#', s, p);
  end;

begin
  Result := false;
  s := st;

// ()
  p := pos('(', s);
  while p > 0 do begin
    i := p;
    j := 1;
    repeat
      i := i + 1;
      if s[i] = '(' then j := j + 1;

      if s[i] = ')' then j := j - 1;
    until (i > Length(s)) or (j <= 0);
    if i > Length(s) then s := s + ')';
    if Recogn(copy(s, p + 1, i - p - 1), v1) = false then Exit;
    delete(s, p, i - p + 1);
    PutValue(p, v1);

    p := pos('(', s);
  end;

// sin, cos, tg, ctg, arcsin, arccos, arctg, arcctg, abs, ln, lg, log, exp
  repeat
    func := fNone;
    p1 := pos('sin', s);

    if p1 > 0 then begin
      func := fSin;
      p := p1;
    end;
    p1 := pos('cos', s);
    if p1 > 0 then begin
      func := fCos;
      p := p1;
    end;
    p1 := pos('tg', s);
    if p1 > 0 then begin
      func := fTg;
      p := p1;
    end;
    p1 := pos('ctg', s);
    if p1 > 0 then begin
      func := fCtg;
      p := p1;

    end;
    p1 := pos('arcsin', s);
    if p1 > 0 then begin
      func := fArcsin;
      p := p1;
    end;
    p1 := pos('arccos', s);
    if p1 > 0 then begin
      func := fArccos;
      p := p1;
    end;
    p1 := pos('arctg', s);
    if p1 > 0 then begin
      func := fArctg;
      p := p1;
    end;
    p1 := pos('arcctg', s);
    if p1 > 0 then begin

      func := fArcctg;
      p := p1;
    end;
    p1 := pos('abs', s);
    if p1 > 0 then begin
      func := fAbs;
      p := p1;
    end;
    p1 := pos('ln', s);
    if p1 > 0 then begin
      func := fLn;
      p := p1;
    end;
    p1 := pos('lg', s);
    if p1 > 0 then begin
      func := fLg;
      p := p1;
    end;
    p1 := pos('exp', s);
    if p1 > 0 then begin

      func := fExp;
      p := p1;
    end;
    if func = fNone then break;

    case func of
      fSin, fCos, fCtg, fAbs, fExp: i := p + 2;
      fArctg: i := p + 4;
      fArcsin, fArccos, fArcctg: i := p + 5;
      else i := p + 1;
    end;
    if FindRightValue(i, v1) = false then Exit;
    delete(s, p, i - p + 1);
    case func of
      fSin: v1 := sin(v1);
      fCos: v1 := cos(v1);

      fTg: begin
        if abs(cos(v1)) < pogr then Exit;
        v1 := sin(v1) / cos(v1);
      end;
      fCtg: begin
        if abs(sin(v1)) < pogr then Exit;
        v1 := cos(v1) / sin(v1);
      end;
      fArcsin: begin
        if Abs(v1) > 1 then Exit;
        v1 := arcsin(v1);
      end;
      fArccos: begin
        if abs(v1) > 1 then Exit;

        v1 := arccos(v1);
      end;
      fArctg: v1 := arctan(v1);
//      fArcctg: v1 := arcctan(v1);
      fAbs: v1 := abs(v1);
      fLn: begin
        if v1 < pogr then Exit;
        v1 := Ln(v1);
      end;
      fLg: begin
        if v1 < 0 then Exit;
        v1 := Log10(v1);
      end;
      fExp: v1 := exp(v1);
    end;
    PutValue(p, v1);
  until func = fNone;

// power
  p := pos('^', s);
  while p > 0 do begin
    if FindRightValue(p, v2) = false then Exit;
    if FindLeftValue(p, i, v1) = false then Exit;
    if (v1 < 0) and (abs(Frac(v2)) > pogr) then Exit;
    if (abs(v1) < pogr) and (v2 < 0) then Exit;
    delete(s, i, 1);
    v1 := Power(v1, v2);
    PutValue(i, v1);
    p := pos('^', s);
  end;

// *, /
  p := pos('*', s);
  p1 := pos('/', s);
  if (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1;
  while p > 0 do begin
    if FindRightValue(p, v2) = false then Exit;
    if FindLeftValue(p, i, v1) = false then Exit;
    if s[i] = '*'
      then v1 := v1 * v2
      else begin
        if abs(v2) < pogr then Exit;

        v1 := v1 / v2;
      end;
    delete(s, i, 1);
    PutValue(i, v1);

    p := pos('*', s);
    p1 := pos('/', s);
    if (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1;
  end;

// +, -
  Num := 0;
  repeat
    Sign := 1;
    while (Length(s) > 0) and (s[1] <> '#') do begin
      if s[1] = '-' then Sign := -Sign
        else if s[1] <> '+' then Exit;

      delete(s, 1, 1);
    end;
    if FindRightValue(0, v1) = false then Exit;
    if Sign < 0
      then Num := Num - v1
      else Num := Num + v1;
  until Length(s) <= 0;

  Result := true;
end;

end.

А это пример использования этого модуля. Он рисует график функции, введенной в Edit1. Константы left и right определяют края графика, а YScale - масштаб по Y.

uses Recognition;

procedure TForm1.Button1Click(Sender: TObject);
const
  left = -10;
  right = 10;
  YScale = 50;
var
  i: integer;
  Num: extended;
  s: String;
  XScale: single;
  col: TColor;
begin
  s := Edit1.Text;
  preparation(s, ['x']);

  XScale := PaintBox1.Width / (right - left);
  randomize;
  col := RGB(random(100), random(100), random(100));
  for i := round(left * XScale) to round(right * XScale) do
    if recogn(ChangeVar(s, 'x', i / XScale), Num) then
      PaintBox1.Canvas.Pixels[round(i - left * XScale),
        round(PaintBox1.Height / 2 - Num * YScale)] := col;
end;

Автор: Даниил Карапетян (delphi4all@narod.ru)

Автор справки: Алексей Денисов (aleksey@sch103.krasnoyarsk.su)

Вариант 3:

Отличная реализация есть в бесплатной библиотеке для дельфи JVCL. Помимо стандартных требований которые решены во всех приведенных примерах, там ещё есть интерфейс для простого подключения любых своих функций, например буквально парой строчек можно подключить распознавание и вычисление гиперболических функций из модуля Math. Настоятельно рекомендую этот пакет всем кто работает на Дельфи - там есть почти всё что требуется для комфортной работы

Автор: Vit

Вариант 4:

Вычислитель математических формул

Вот что я обнаружил несколько дней назад при просмотре зарубежных источников:

FORMULA должна быть стокой, содержащей формулу. Допускаются переменные x, y и z, а также операторы, перечисленные ниже. Пример:

sin(x)*cos(x^y)+exp(cos(x))

Использование:

uses EVALCOMP;

var
  calc: EVALVEC; {evalvec - указатель на объект, определяемый evalcomp}
  FORMULA: string;
begin
  FORMULA := 'x+y+z';

  new(calc, init(FORMULA));
  (Построение дерева оценки)

  writeln(calc^.eval1d(7));
  (x = 7 y = 0 z = 0; result: 7)
    writeln(calc^.eval2d(7, 8));
  (x = 7 y = 8 z = 0; result: 15)
    writeln(calc^.eval3d(7, 8, 9));
  (x = 7 y = 8 z = 9; result: 24)

  dispose(calc, done);
  (разрушение дерева оценки)
end.

Допустимые операторы:

x <l; x > y ; // Логические операторы возвращают 1 в случае истины и 0 если ложь.
x <l;= y x >= y x > y x <l; y x = y x + y x - y x eor y //( исключающее или )
x or y x * y x / y x and y x mod y x div y x^y //( степень ) x shl y x shr y not (x)
sinc (x) sinh (x) cosh (x) tanh (x) coth (x) sin (x) cos (x) tan (x) cot (x) sqrt (x) sqr (x)
arcsinh (x) arccosh (x) arctanh (x) arccoth (x) arcsin (x) arccos (x) arctan (x) arccot (x)
heavy (x) //; 1 для положительных чисел, 0 для остальных
sgn (x) //; 1 для положительных чисел, -1 для отрицательных и 0 для нуля
frac (x) exp (x) abs (x) trunc (x) ln (x) odd (x) pred (x) succ (x)
round (x) int (x) fac (x) //; x(x-1)(x-2)...321
rnd // Случайное число в диапазоне [0,1]
rnd (x) //; Случайное число в диапазоне [0,x]
pi e

``` unit evalcomp;

interface

type fun = function(x, y: real): real;

evalvec = ^evalobj; evalobj = object f1, f2: evalvec; f1x, f2y: real; f3: fun; function eval: real; function eval1d(x: real): real; function eval2d(x, y: real): real; function eval3d(x, y, z: real): real; constructor init(st: string); destructor done; end; var evalx, evaly, evalz: real;

implementation

var analysetmp: fun;

function search(text, code: string; var pos: integer): boolean; var i, count: integer;

flag: boolean; newtext: string; begin

if length(text) < l; length(code) then begin search := false; exit; end; flag := false; pos := length(text) - length(code) + 1; repeat if code = copy(text, pos, length(code)) then flag := true else dec(pos); if flag then begin count := 0; for i := pos + 1 to length(text) do begin if copy(text, i, 1) = '(' then inc(count); if copy(text, i, 1) = ')' then dec(count); end; if count < l;

0 then begin dec(pos); flag := false; end; end; until (flag = true) or (pos = 0); search := flag; end;

function myid(x, y: real): real; begin

myid := x; end;

function myunequal(x, y: real): real; begin

if x <> y then myunequal := 1 else myunequal := 0; end;

function mylessequal(x, y: real): real; begin

if x <= y then mylessequal := 1 else mylessequal := 0; end;

function mygreaterequal(x, y: real): real; begin

if x >= y then mygreaterequal := 1 else mygreaterequal := 0; end;

function mygreater(x, y: real): real; begin

if x > y then mygreater := 1 else mygreater := 0; end;

function myless(x, y: real): real; begin

if x < y then myless := 1 else myless := 0; end;

function myequal(x, y: real): real; begin

if x = y then myequal := 1 else myequal := 0; end;

function myadd(x, y: real): real; begin

myadd := x + y; end;

function mysub(x, y: real): real; begin

mysub := x - y; end;

function myeor(x, y: real): real; begin

myeor := trunc(x) xor trunc(y); end;

function myor(x, y: real): real; begin

myor := trunc(x) or trunc(y); end;

function mymult(x, y: real): real; begin

mymult := x * y; end;

function mydivid(x, y: real): real; begin

mydivid := x / y; end;

function myand(x, y: real): real; begin

myand := trunc(x) and trunc(y); end;

function mymod(x, y: real): real; begin

mymod := trunc(x) mod trunc(y); end;

function mydiv(x, y: real): real; begin

mydiv := trunc(x) div trunc(y); end;

function mypower(x, y: real): real; begin

if x = 0 then mypower := 0 else if x > 0 then mypower := exp(y * ln(x)) else if trunc(y) <> y then begin writeln(' Немогу вычислить x^y '); halt; end else if odd(trunc(y)) = true then mypower := -exp(y * ln(-x)) else mypower := exp(y * ln(-x)) end;

function myshl(x, y: real): real; begin

myshl := trunc(x) shl trunc(y); end;

function myshr(x, y: real): real; begin

myshr := trunc(x) shr trunc(y); end;

function mynot(x, y: real): real; begin

mynot := not trunc(x); end;

function mysinc(x, y: real): real; begin if x = 0 then

mysinc := 1

else

mysinc := sin(x) / x

end;

function mysinh(x, y: real): real; begin mysinh := 0.5 * (exp(x) - exp(-x)) end;

function mycosh(x, y: real): real; begin mycosh := 0.5 * (exp(x) + exp(-x)) end;

function mytanh(x, y: real): real; begin mytanh := mysinh(x, 0) / mycosh(x, 0) end;

function mycoth(x, y: real): real; begin mycoth := mycosh(x, 0) / mysinh(x, 0) end;

function mysin(x, y: real): real; begin mysin := sin(x) end;

function mycos(x, y: real): real; begin mycos := cos(x) end;

function mytan(x, y: real): real; begin mytan := sin(x) / cos(x) end;

function mycot(x, y: real): real; begin mycot := cos(x) / sin(x) end;

function mysqrt(x, y: real): real; begin mysqrt := sqrt(x) end;

function mysqr(x, y: real): real; begin mysqr := sqr(x) end;

function myarcsinh(x, y: real): real; begin myarcsinh := ln(x + sqrt(sqr(x) + 1)) end;

function mysgn(x, y: real): real; begin if x = 0 then

mysgn := 0

else

mysgn := x / abs(x)

end;

function myarccosh(x, y: real): real; begin myarccosh := ln(x + mysgn(x, 0) * sqrt(sqr(x) - 1)) end;

function myarctanh(x, y: real): real; begin myarctanh := ln((1 + x) / (1 - x)) / 2 end;

function myarccoth(x, y: real): real; begin myarccoth := ln((1 - x) / (1 + x)) / 2 end;

function myarcsin(x, y: real): real; begin if x = 1 then

myarcsin := pi / 2

else

myarcsin := arctan(x / sqrt(1 - sqr(x)))

end;

function myarccos(x, y: real): real; begin myarccos := pi / 2 - myarcsin(x, 0) end;

function myarctan(x, y: real): real; begin myarctan := arctan(x); end;

function myarccot(x, y: real): real; begin myarccot := pi / 2 - arctan(x) end;

function myheavy(x, y: real): real; begin myheavy := mygreater(x, 0) end;

function myfrac(x, y: real): real; begin myfrac := frac(x) end;

function myexp(x, y: real): real; begin myexp := exp(x) end;

function myabs(x, y: real): real; begin myabs := abs(x) end;

function mytrunc(x, y: real): real; begin mytrunc := trunc(x) end;

function myln(x, y: real): real; begin myln := ln(x) end;

function myodd(x, y: real): real; begin if odd(trunc(x)) then

myodd := 1

else

myodd := 0;

end;

function mypred(x, y: real): real; begin mypred := pred(trunc(x)); end;

function mysucc(x, y: real): real; begin mysucc := succ(trunc(x)); end;

function myround(x, y: real): real; begin myround := round(x); end;

function myint(x, y: real): real; begin myint := int(x); end;

function myfac(x, y: real): real; var n: integer;

r: real; begin if x < 0 then begin writeln(' Немогу вычислить факториал '); halt; end; if x = 0 then myfac := 1 else

begin r := 1; for n := 1 to trunc(x) do r := r * n; myfac := r; end; end;

function myrnd(x, y: real): real; begin myrnd := random; end;

function myrandom(x, y: real): real; begin myrandom := random(trunc(x)); end;

function myevalx(x, y: real): real; begin myevalx := evalx; end;

function myevaly(x, y: real): real; begin myevaly := evaly; end;

function myevalz(x, y: real): real; begin myevalz := evalz; end;

procedure analyse(st: string; var st2, st3: string); label start;

var pos: integer; value: real; newterm, term: string; begin term := st; start:

if term = '' then begin analysetmp := myid; st2 := '0'; st3 := ''; exit; end; newterm := ''; for pos := 1 to length(term) do if copy(term, pos, 1) <> ' ' then newterm := newterm + copy(term, pos, 1); term := newterm; if term = '' then begin analysetmp := myid; st2 := '0'; st3 := ''; exit; end; val(term, value, pos); if pos = 0 then begin analysetmp := myid; st2 := term; st3 := ''; exit; end; if search(term, '<>', pos) then begin analysetmp := myunequal; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 2, length(term) - pos - 1); exit; end; if search(term, '<=', pos) then begin analysetmp := mylessequal; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 2, length(term) - pos - 1); exit; end; if search(term, '>=', pos) then begin analysetmp := mygreaterequal; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 2, length(term) - pos - 1); exit; end; if search(term, '>', pos) then begin analysetmp := mygreater; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 1, length(term) - pos); exit; end; if search(term, '<', pos) then begin analysetmp := myless; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 1, length(term) - pos); exit; end; if search(term, '=', pos) then begin analysetmp := myequal; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 1, length(term) - pos); exit; end; if search(term, '+', pos) then begin analysetmp := myadd; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 1, length(term) - pos); exit; end; if search(term, '-', pos) then begin analysetmp := mysub; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 1, length(term) - pos); exit; end; if search(term, 'eor', pos) then begin analysetmp := myeor; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 3, length(term) - pos - 2); exit; end; if search(term, 'or', pos) then begin analysetmp := myor; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 2, length(term) - pos - 1); exit; end; if search(term, '*', pos) then begin analysetmp := mymult; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 1, length(term) - pos); exit; end; if search(term, '/', pos) then begin analysetmp := mydivid; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 1, length(term) - pos); exit; end; if search(term, 'and', pos) then begin analysetmp := myand; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 3, length(term) - pos - 2); exit; end; if search(term, 'mod', pos) then begin analysetmp := mymod; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 3, length(term) - pos - 2); exit; end; if search(term, 'div', pos) then begin analysetmp := mydiv; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 3, length(term) - pos - 2); exit; end; if search(term, '^', pos) then begin analysetmp := mypower; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 1, length(term) - pos); exit; end; if search(term, 'shl', pos) then begin analysetmp := myshl; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 3, length(term) - pos - 2); exit; end; if search(term, 'shr', pos) then begin analysetmp := myshr; st2 := copy(term, 1, pos - 1); st3 := copy(term, pos + 3, length(term) - pos - 2); exit; end; if copy(term, 1, 1) = '(' then begin term := copy(term, 2, length(term) - 2); goto start; end; if copy(term, 1, 3) = 'not' then begin analysetmp := mynot; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if copy(term, 1, 4) = 'sinc' then begin analysetmp := mysinc; st2 := copy(term, 5, length(term) - 4); st3 := ''; exit; end; if copy(term, 1, 4) = 'sinh' then begin analysetmp := mysinh; st2 := copy(term, 5, length(term) - 4); st3 := ''; exit; end; if copy(term, 1, 4) = 'cosh' then begin analysetmp := mycosh; st2 := copy(term, 5, length(term) - 4); st3 := ''; exit; end; if copy(term, 1, 4) = 'tanh' then begin analysetmp := mytanh; st2 := copy(term, 5, length(term) - 4); st3 := ''; exit; end; if copy(term, 1, 4) = 'coth' then begin analysetmp := mycoth; st2 := copy(term, 5, length(term) - 4); st3 := ''; exit; end; if copy(term, 1, 3) = 'sin' then begin analysetmp := mysin; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if copy(term, 1, 3) = 'cos' then begin analysetmp := mycos; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if copy(term, 1, 3) = 'tan' then begin analysetmp := mytan; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if copy(term, 1, 3) = 'cot' then begin analysetmp := mycot; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if copy(term, 1, 4) = 'sqrt' then begin analysetmp := mysqrt; st2 := copy(term, 5, length(term) - 4); st3 := ''; exit; end; if copy(term, 1, 3) = 'sqr' then begin analysetmp := mysqr; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if copy(term, 1, 7) = 'arcsinh' then begin analysetmp := myarcsinh; st2 := copy(term, 8, length(term) - 7); st3 := ''; exit; end; if copy(term, 1, 7) = 'arccosh' then begin analysetmp := myarccosh; st2 := copy(term, 8, length(term) - 7); st3 := ''; exit; end; if copy(term, 1, 7) = 'arctanh' then begin analysetmp := myarctanh; st2 := copy(term, 8, length(term) - 7); st3 := ''; exit; end; if copy(term, 1, 7) = 'arccoth' then begin analysetmp := myarccoth; st2 := copy(term, 8, length(term) - 7); st3 := ''; exit; end; if copy(term, 1, 6) = 'arcsin' then begin analysetmp := myarcsin; st2 := copy(term, 7, length(term) - 6); st3 := ''; exit; end; if copy(term, 1, 6) = 'arccos' then begin analysetmp := myarccos; st2 := copy(term, 7, length(term) - 6); st3 := ''; exit; end; if copy(term, 1, 6) = 'arctan' then begin analysetmp := myarctan; st2 := copy(term, 7, length(term) - 6); st3 := ''; exit; end; if copy(term, 1, 6) = 'arccot' then begin analysetmp := myarccot; st2 := copy(term, 7, length(term) - 6); st3 := ''; exit; end; if copy(term, 1, 5) = 'heavy' then begin analysetmp := myheavy; st2 := copy(term, 6, length(term) - 5); st3 := ''; exit; end; if copy(term, 1, 3) = 'sgn' then begin analysetmp := mysgn; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if copy(term, 1, 4) = 'frac' then begin analysetmp := myfrac; st2 := copy(term, 5, length(term) - 4); st3 := ''; exit; end; if copy(term, 1, 3) = 'exp' then begin analysetmp := myexp; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if copy(term, 1, 3) = 'abs' then begin analysetmp := myabs; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if copy(term, 1, 5) = 'trunc' then begin analysetmp := mytrunc; st2 := copy(term, 6, length(term) - 5); st3 := ''; exit; end; if copy(term, 1, 2) = 'ln' then begin analysetmp := myln; st2 := copy(term, 3, length(term) - 2); st3 := ''; exit; end; if copy(term, 1, 3) = 'odd' then begin analysetmp := myodd; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if copy(term, 1, 4) = 'pred' then begin analysetmp := mypred; st2 := copy(term, 5, length(term) - 4); st3 := ''; exit; end; if copy(term, 1, 4) = 'succ' then begin analysetmp := mysucc; st2 := copy(term, 5, length(term) - 4); st3 := ''; exit; end; if copy(term, 1, 5) = 'round' then begin analysetmp := myround; st2 := copy(term, 6, length(term) - 5); st3 := ''; exit; end; if copy(term, 1, 3) = 'int' then begin analysetmp := myint; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if copy(term, 1, 3) = 'fac' then begin analysetmp := myfac; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if term = 'rnd' then begin analysetmp := myrnd; st2 := ''; st3 := ''; exit; end; if copy(term, 1, 3) = 'rnd' then begin analysetmp := myrandom; st2 := copy(term, 4, length(term) - 3); st3 := ''; exit; end; if term = 'x' then begin analysetmp := myevalx; st2 := ''; st3 := ''; exit; end; if term = 'y' then begin analysetmp := myevaly; st2 := ''; st3 := ''; exit; end; if term = 'z' then begin analysetmp := myevalz; st2 := ''; st3 := ''; exit; end; if (term = 'pi') then begin analysetmp := myid; str(pi, st2); st3 := ''; exit; end; if term = 'e' then begin analysetmp := myid; str(exp(1), st2); sst3 := ''; exit; end; writeln(' ВНИМАНИЕ : НЕДЕКОДИРУЕМАЯ ФОРМУЛА '); analysetmp := myid; st2 := ''; st3 := ''; end;

function evalobj.eval: real; var tmpx, tmpy: real; begin

if f1 = nil then tmpx := f1x else tmpx := f1^.eval; if f2 = nil then tmpy := f2y else tmpy := f2^.eval; eval := f3(tmpx, tmpy); end;

function evalobj.eval1d(x: real): real; begin evalx := x; evaly := 0; evalz := 0; eval1d := eval; end;

function evalobj.eval2d(x, y: real): real; begin evalx := x; evaly := y; evalz := 0; eval2d := eval; end;

function evalobj.eval3d(x, y, z: real): real; begin evalx := x; evaly := y; evalz := z; eval3d := eval; end;

constructor evalobj.init(st: string); var st2, st3: string;

error: integer; begin f1 := nil; f2 := nil; analyse(st, st2, st3); f3 := analysetmp; val(st2, f1x, error); if st2 = '' then begin

f1x := 0;
error := 0;

end; if error <> 0 then

new(f1, init(st2));

val(st3, f2y, error); if st3 = '' then begin

f2y := 0;
error := 0;

end; if error <> 0 then

new(f2, init(st3));

end;

destructor evalobj.done; begin if f1 <> nil then

dispose(f1, done);

if f2 <> nil then

dispose(f2, done);

end;

end. ```

Source: DelphiWorld 6.0 https://delphiworld.narod.ru/

Вариант 5:

unit MathComponent;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, math;

type
  TMathtype = (mtnil, mtoperator, mtlbracket, mtrbracket, mtoperand);

type
  TMathOperatortype = (monone, moadd, mosub, modiv, momul, mopow);

type
  pmathchar = ^Tmathchar;
  TMathChar = record
  case mathtype: Tmathtype of
    mtoperand:(data:extended);
    mtoperator:(op:TMathOperatortype);
  end;

type
  TMathControl = class(TComponent)
  private
    input, output, stack: array of tmathchar;
    fmathstring: string;
    function getresult:extended;
    function calculate(operand1,operand2,operator:Tmathchar):extended;
    function getoperator(c:char):TMathOperatortype;
    function getoperand(mid:integer;var len:integer):extended;
    procedure processstring;
    procedure convertinfixtopostfix;
    function isdigit(c:char):boolean;
    function isoperator(c:char):boolean;
    function getprecedence(mop:TMathOperatortype):integer;
  protected
  published
    property MathExpression:string read fmathstring write fmathstring;
    property MathResult:extended read getresult;
  end;

procedure register;

implementation

function Tmathcontrol.calculate(operand1,operand2,operator:Tmathchar):extended;
begin
  result:=0;
  case operator.op of
    moadd:
      result:=operand1.data + operand2.data;
    mosub:
      result:=operand1.data - operand2.data;
    momul:
      result:=operand1.data * operand2.data;
    modiv:
      if (operand1.data<>0) and (operand2.data<>0) then
        result:=operand1.data / operand2.data
      else
        result := 0;
    mopow:
      result:=power(operand1.data, operand2.data);
  end;
end;

function Tmathcontrol.getresult:extended;
var
  i:integer;
  tmp1,tmp2,tmp3:tmathchar;
begin
  convertinfixtopostfix;
  setlength(stack,0);
  for i:=0 to length(output)-1 do
  begin
    if output[i].mathtype=mtoperand then
    begin
      setlength(stack,length(stack)+1);
      stack[length(stack)-1]:=output[i];
    end
    else
    if output[i].mathtype=mtoperator then
    begin
      tmp1:=stack[length(stack)-1];
      tmp2:=stack[length(stack)-2];
      setlength(stack,length(stack)-2);
      tmp3.mathtype:=mtoperand;
      tmp3.data:=calculate(tmp2,tmp1,output[i]);
      setlength(stack,length(stack)+1);
      stack[length(stack)-1]:=tmp3;
    end;
  end;
  result:=stack[0].data;
  setlength(stack,0);
  setlength(input,0);
  setlength(output,0);
end;

function Tmathcontrol.getoperator(c:char):TMathOperatortype;
begin
  result:=monone;
  if c='+' then
    result:=moadd
  else
  if c='*' then
    result:=momul
  else
  if c='/' then
    result:=modiv
  else
  if c='-' then
    result:=mosub
  else
  if c='^' then
    result:=mopow;
end;

function Tmathcontrol.getoperand(mid:integer;var len:integer):extended;
var
  i,j:integer;
  tmpnum:string;
begin
  j:=1;
  for i:=mid to length(fmathstring)-1 do
  begin
    if isdigit(fmathstring[i]) then
    begin
      if j<=20 then
        tmpnum:=tmpnum+fmathstring[i];
      j:=j+1;
    end
    else
      break;
  end;
  result:=strtofloat(tmpnum);
  len:=length(tmpnum);
end;

procedure Tmathcontrol.processstring;
var
  i:integer;
  numlen:integer;
begin
  i:=0;
  numlen:=0;
  setlength(output,0);
  setlength(input,0);
  setlength(stack,0);
  fmathstring:='('+fmathstring+')';
  setlength(input,length(fmathstring));
  while i<=length(fmathstring)-1 do
  begin
    if fmathstring[i+1]='(' then
    begin
      input[i].mathtype:=mtlbracket;
      i:=i+1;
    end
    else
    if fmathstring[i+1]=')' then
    begin
      input[i].mathtype:=mtrbracket;
      i:=i+1;
    end
    else
    if isoperator(fmathstring[i+1]) then
    begin
      input[i].mathtype:=mtoperator;
      input[i].op:=getoperator(fmathstring[i+1]);
      i:=i+1;
    end
    else
    if isdigit(fmathstring[i+1]) then
    begin
      input[i].mathtype:=mtoperand;
      input[i].data:=getoperand(i+1,numlen);
      i:=i+numlen;
    end;
  end;
end;


function Tmathcontrol.isoperator(c:char):boolean;
begin
  result:=false;
  if (c='+') or (c='-') or (c='*') or (c='/') or (c='^') then
    result:=true;
end;

function Tmathcontrol.isdigit(c:char):boolean;
begin
  result:=false;
  if ((integer(c)> 47) and (integer(c)< 58)) or (c='.') then
    result:=true;
end;

function Tmathcontrol.getprecedence(mop:TMathOperatortype):integer;
begin
  result:=-1;
  case mop of
    moadd: result := 1;
    mosub: result := 1;
    momul: result := 2;
    modiv: result := 2;
    mopow: result := 3;
  end;
end;

procedure Tmathcontrol.convertinfixtopostfix;
var
  i,j,prec:integer;
begin
  processstring;
  for i:=0 to length(input)-1 do
  begin
    if input[i].mathtype=mtoperand then
    begin
      setlength(output,length(output)+1);
      output[length(output)-1]:=input[i];
    end
    else
    if input[i].mathtype=mtlbracket then
    begin
      setlength(stack,length(stack)+1);
      stack[length(stack)-1]:=input[i];
    end
    else
    if input[i].mathtype=mtoperator then
    begin
      prec:=getprecedence(input[i].op);
      j:=length(stack)-1;
      if j>=0 then
      begin
        while(getprecedence(stack[j].op)>=prec) and (j>=0) do
        begin
          setlength(output,length(output)+1);
          output[length(output)-1]:=stack[j];
          setlength(stack,length(stack)-1);
          j:=j-1;
        end;
        setlength(stack,length(stack)+1);
        stack[length(stack)-1]:=input[i];
      end;
    end
    else
    if input[i].mathtype=mtrbracket then
    begin
      j:=length(stack)-1;
      if j>=0 then
      begin
        while(stack[j].mathtype<>mtlbracket) and (j>=0) do
        begin
          setlength(output,length(output)+1);
          output[length(output)-1]:=stack[j];
          setlength(stack,length(stack)-1);
          j:=j-1;
        end;
        if j>=0 then
          setlength(stack,length(stack)-1);
      end;
    end;
  end;
end;

procedure register;
begin
  RegisterComponents('Samples', [TMathControl]);
end; 

end.

Source: DelphiWorld 6.0 https://delphiworld.narod.ru/

Вариант 6:

function Calculate(SMyExpression: string; digits: Byte): string;
   // Calculate a simple expression 
  // Supported are:  Real Numbers, parenthesis 
var
   z: Char;
   ipos: Integer;

   function StrToReal(chaine: string): Real;
   var
     r: Real;
     Pos: Integer;
   begin
     Val(chaine, r, Pos);
     if Pos > 0 then Val(Copy(chaine, 1, Pos - 1), r, Pos);
     Result := r;
   end;

   function RealToStr(inreal: Extended; digits: Byte): string;
   var
     S: string;
   begin
     Str(inreal: 0: digits, S);
     realToStr := S;
   end;

   procedure NextChar;
   var
     s: string;
   begin
     if ipos > Length(SMyExpression) then
     begin
       z := #9;
       Exit;
     end
     else
     begin
       s := Copy(SMyExpression, ipos, 1);
       z := s[1];
       Inc(ipos);
     end;
     if z = ' ' then nextchar;
   end;

   function Expression: Real;
   var
     w: Real;

     function Factor: Real;
     var
       ws: string;
     begin
       Nextchar;
       if z in ['0'..'9'] then
       begin
         ws := '';
         repeat
           ws := ws + z;
           nextchar
         until not (z in ['0'..'9', '.']);
         Factor := StrToReal(ws);
       end
       else if z = '(' then
       begin
         Factor := Expression;
         nextchar
       end
       else if z = '+' then Factor := +Factor
       else if Z = '-' then Factor := -Factor;
     end;

     function Term: Real;
     var
       W: Real;
     begin
       W := Factor;
       while Z in ['*', '/'] do
         if z = '*' then w := w * Factor
       else
         w := w / Factor;
       Term := w;
     end;
   begin
     w := term;
     while z in ['+', '-'] do
       if z = '+' then w := w + term
     else
       w := w - term;
     Expression := w;
   end;
 begin
   ipos   := 1;
   Result := RealToStr(Expression, digits);
 end;


 procedure TForm1.Button1Click(Sender: TObject);
 var
   sMyExpression: string;
 begin
   sMyExpression := '12.5*6+18/3.2+2*(5-6.23)';
   ShowMessage(sMyExpression + ' = ' + Calculate(sMyExpression, 3));
 end;

Source: https://www.swissdelphicenter.ch