Как вычислить математическое выражение
Falk0ner, вс, 06/07/2008 - 15:35.
Допустимые операторы:
x y ; // Логические операторы возвращают 1 в случае истины и 0 если ложь.
x
x > y
x
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
DelphiWorld 6.0
Зачастую пользователь должен ввести что-то типа "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.
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;
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.
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
x
x > y
x
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.
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
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.
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
// 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;
Отправить комментарий