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

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

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)
Взято с Vingrad.ru http://forum.vingrad.ru
В 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;

Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru
Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su

Отличная реализация есть в бесплатной библиотеке для дельфи JVCL. Помимо стандартных требований которые решены во всех приведенных примерах, там ещё есть интерфейс для простого подключения любых своих функций, например буквально парой строчек можно подключить распознавание и вычисление гиперболических функций из модуля Math. Настоятельно рекомендую этот пакет всем кто работает на Дельфи - там есть почти всё что требуется для комфортной работы
Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)

Вычислитель математических формул
Вот что я обнаружил несколько дней назад при просмотре зарубежных источников:
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 y ; // Логические операторы возвращают 1 в случае истины и 0 если ложь.
x x >= y
x > y
x 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.


DelphiWorld 6.0

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.
DelphiWorld 6.0

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 Char;
  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
  char;
  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;
Взято с сайта: http://www.swissdelphicenter.ch

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
Проверка
Антиспам проверка
Image CAPTCHA
...