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

Previous  Top  Next

    
 

 

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

 

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

или

 

http://www.torry.net

 

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

 

©Drkb::04227

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)

 

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

 


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

 

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

 

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

 

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

Code:

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.

Code:

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;

©Drkb::04228

 

Автор советов: Даниил Карапетян

e-mail: delphi4all@narod.ru

 

Автор справки: Алексей Денисов

e-mail: aleksey@sch103.krasnoyarsk.su

 

 

 


 

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

©Drkb::04229

Автор: 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))

 

 

 

 

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

Code:

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

Code:

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.

 

 

 

©Drkb::04230

http://delphiworld.narod.ru/

DelphiWorld 6.0

 

 


 

 

Code:

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.

 

©Drkb::04231

http://delphiworld.narod.ru/

DelphiWorld 6.0

 

 

Code:

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;

©Drkb::04232

Взято с сайта: http://www.swissdelphicenter.ch