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

== Модуль Parsing из RxLib ==
Зачастую пользователь должен ввести что-то типа "1+2/(3*4)" и программа должна разобрать выражение и произвести вычисления. Делается это с помощью рекурсивных функций, которые постепенно разбирают выражение. К счастью не обязательно изобретать велосипед: в бесплатной библиотеке RxLib есть модуль Parsing.pas включающий в себя класс для вычисления математических выражений, библиотеку можно взять на
http://www.rxlib.ru/Downl/Downl.htm
или
http://www.torry.net
Модуль Parsing.pas вполне может работать отдельно и без установки пакета компонент (но в таком случае вам придется взять еще несколько inc файлов помимо него).
Author: Vit
Source: http://forum.vingrad.ru
ID: 04227
----
== Разбор строки с формулой ==
В 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
 begin
 if Recogn(ChangeVar(s, 'x', i / XScale), Num) then
 PaintBox1.Canvas.Pixels[Round(i - left * XScale),
 Round(PaintBox1.Height / 2 - Num * YScale)] := col;
 end;
end;
 e-mail: delphi4all@narod.ru
 e-mail: aleksey@sch103.krasnoyarsk.su
Author: Автор советов: Даниил Карапетян
Author: Автор справки: Алексей Денисов
ID: 04228
----
== JVCL ==
Отличная реализация есть в бесплатной библиотеке для Delphi JVCL. Помимо стандартных требований которые решены во всех приведенных примерах, там ещё есть интерфейс для простого подключения любых своих функций, например буквально парой строчек можно подключить распознавание и вычисление гиперболических функций из модуля Math. Настоятельно рекомендую этот пакет всем кто работает на Дельфи - там есть почти всё что требуется для комфортной работы
Author: Vit
ID: 04229
----
== Вычислитель математических формул ==
Вот что я обнаружил несколько дней назад при просмотре зарубежных источников:
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;> 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)*...*3*2*1
 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: http://delphiworld.narod.ru/
ID: 04230
----
== Компонент разбора формул ==
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, AOperator: 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;
 published
 property MathExpression: string read FMathString write FMathString;
 property MathResult: Extended read GetResult;
 end;
procedure register;
implementation
function TMathControl.Calculate(Operand1, Operand2, AOperator: 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: http://delphiworld.narod.ru/
ID: 04231
----
== Функция вычисления простых выражений ==
// Calculate a simple expression
// Supported are: Real Numbers, parenthesis
function Calculate(SMyExpression: string; digits: Byte): string;
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: Взято с сайта: http://www.swissdelphicenter.ch
ID: 04232
Category:Алгоритмы
Category:Математика
Category:Работа с текстом