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

Материал из DRKB


Модуль Parsing из RxLib[править | править код]

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

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

или

http://www.torry.net

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


Author: Vit
Source: http://forum.vingrad.ru
ID: 04227



Разбор строки с формулой[править | править код]

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

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

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

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

unit Recognition;

interface

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

type
  TVar = set of Char;

procedure Preparation(var s: String; variables: TVar);
function ChangeVar(s: String; c: Char; value: extended): String;
function Recogn(st: String; var Num: Extended): Boolean;

implementation


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

  // " "
  repeat
    i := Pos(' ', s);
    if i <= 0 then Break;
    Delete(s, i, 1);
  until 1 = 0;

  s := LowerCase(s);

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

  // Pi
  repeat
    i := Pos('pi', s);
    if i <= 0 then Break;
    Delete(s, i, 2);
    Insert(FloatToStr(Pi), s, i);
  until 1 = 0;

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

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

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

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

end;

function ChangeVar(s: String; c: Char; value: Extended): String;
var
  p: Integer;
begin
  Result := s;
  repeat
    p := Pos(c, Result);
    if p <= 0 then Break;
    Delete(Result, p, 1);
    Insert(FloatToStr(value), Result, p);
  until 1 = 0;
end;

function Recogn(st: String; var Num: Extended): Boolean;
const
  pogr = 1E-5;
var
  p, p1: Integer;
  i, j: Integer;
  v1, v2: Extended;
  func: (fNone, fSin, fCos, fTg, fCtg, fArcsin, fArccos, fArctg, fArcctg, fAbs, fLn, fLg, fExp);
  Sign: Integer;
  s: String;
  s1: String;

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

    Margin := i;
    try
      Value := StrToFloat(Copy(s, i + 1, p - i - 2));
      Result := True;
    except
      Result := False
    end;
    Delete(s, i, p - i);
  end;

  function FindRightValue(p: Integer; var Value: Extended): Boolean;
  var
    i: Integer;
  begin
    i := p + 1;
    repeat i := i + 1 until (i > Length(s)) or (s[i] = '#');
    i := i - 1;
    s1 := Copy(s, p + 2, i - p - 1);

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

  procedure PutValue(p: Integer; NewValue: Extended);
  begin
    Insert('#' + FloatToStr(v1) + '#', s, p);
  end;

begin
  Result := False;
  s := st;

  // ()
  p := Pos('(', s);
  while p > 0 do
  begin
    i := p;
    j := 1;
    repeat
      i := i + 1;
      if s[i] = '(' then j := j + 1;
      if s[i] = ')' then j := j - 1;
    until (i > Length(s)) or (j <= 0);
    if i > Length(s) then s := s + ')';
    if Recogn(Copy(s, p + 1, i - p - 1), v1) = False then Exit;
    Delete(s, p, i - p + 1);
    PutValue(p, v1);

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

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

    if p1 > 0 then
    begin
      func := fSin;
      p := p1;
    end;
    p1 := Pos('cos', s);
    if p1 > 0 then
    begin
      func := fCos;
      p := p1;
    end;
    p1 := Pos('tg', s);
    if p1 > 0 then
    begin
      func := fTg;
      p := p1;
    end;
    p1 := Pos('ctg', s);
    if p1 > 0 then
    begin
      func := fCtg;
      p := p1;
    end;
    p1 := Pos('arcsin', s);
    if p1 > 0 then
    begin
      func := fArcsin;
      p := p1;
    end;
    p1 := Pos('arccos', s);
    if p1 > 0 then
    begin
      func := fArccos;
      p := p1;
    end;
    p1 := Pos('arctg', s);
    if p1 > 0 then
    begin
      func := fArctg;
      p := p1;
    end;
    p1 := Pos('arcctg', s);
    if p1 > 0 then
    begin
      func := fArcctg;
      p := p1;
    end;
    p1 := Pos('abs', s);
    if p1 > 0 then
    begin
      func := fAbs;
      p := p1;
    end;
    p1 := Pos('ln', s);
    if p1 > 0 then
    begin
      func := fLn;
      p := p1;
    end;
    p1 := Pos('lg', s);
    if p1 > 0 then
    begin
      func := fLg;
      p := p1;
    end;
    p1 := Pos('exp', s);
    if p1 > 0 then
    begin
      func := fExp;
      p := p1;
    end;
    if func = fNone then break;

    case func of
      fSin, fCos, fCtg, fAbs, fExp: i := p + 2;
      fArctg: i := p + 4;
      fArcsin, fArccos, fArcctg: i := p + 5;
      else i := p + 1;
    end;
    if FindRightValue(i, v1) = False then Exit;
    Delete(s, p, i - p + 1);
    case func of
      fSin: v1 := sin(v1);
      fCos: v1 := cos(v1);
      fTg:
      begin
        if abs(cos(v1)) < pogr then Exit;
        v1 := sin(v1) / cos(v1);
      end;
      fCtg:
      begin
        if abs(sin(v1)) < pogr then Exit;
        v1 := cos(v1) / sin(v1);
      end;
      fArcsin:
      begin
        if Abs(v1) > 1 then Exit;
        v1 := arcsin(v1);
      end;
      fArccos:
      begin
        if abs(v1) > 1 then Exit;
        v1 := arccos(v1);
      end;
      fArctg: v1 := arctan(v1);
//      fArcctg: v1 := arcctan(v1);
      fAbs: v1 := abs(v1);
      fLn:
      begin
        if v1 < pogr then Exit;
        v1 := Ln(v1);
      end;
      fLg:
      begin
        if v1 < 0 then Exit;
        v1 := Log10(v1);
      end;
      fExp: v1 := exp(v1);
    end;
    PutValue(p, v1);
  until func = fNone;

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

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

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

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

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

  Result := True;
end;

end.


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

uses Recognition;

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

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


e-mail: delphi4all@narod.ru
e-mail: aleksey@sch103.krasnoyarsk.su


Author: Автор советов: Даниил Карапетян
Author: Автор справки: Алексей Денисов
ID: 04228



JVCL[править | править код]

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


Author: Vit
ID: 04229



Вычислитель математических формул[править | править код]

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

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


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


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

uses EVALCOMP;

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

  New(calc, Init(FORMULA));
  { Построение дерева оценки }

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

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


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

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

interface

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

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

implementation

var
  analysetmp: fun;

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

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

function myunequal(x, y: real): real;
begin
  if x <> y then
    myunequal := 1
  else
    myunequal := 0;
end;

function mylessequal(x, y: real): real;
begin
  if x <= y then
    mylessequal := 1
  else
    mylessequal := 0;
end;

function mygreaterequal(x, y: real): real;
begin
  if x >= y then
    mygreaterequal := 1
  else
    mygreaterequal := 0;
end;

function mygreater(x, y: real): real;
begin
  if x > y then
    mygreater := 1
  else
    mygreater := 0;
end;

function myless(x, y: real): real;
begin
  if x < y then
    myless := 1
  else
    myless := 0;
end;

function myequal(x, y: real): real;
begin
  if x = y then
    myequal := 1
  else
    myequal := 0;
end;

function myadd(x, y: real): real;
begin
  myadd := x + y;
end;

function mysub(x, y: real): real;
begin
  mysub := x - y;
end;

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

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

function mymult(x, y: real): real;
begin
  mymult := x * y;
end;

function mydivid(x, y: real): real;
begin
  mydivid := x / y;
end;

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

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

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

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

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

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

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

function mysinc(x, y: real): real;
begin
  if x = 0 then
    mysinc := 1
  else
    mysinc := sin(x) / x
end;

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

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

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

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

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

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

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

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

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

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

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

function mysgn(x, y: real): real;
begin
  if x = 0 then
    mysgn := 0
  else
    mysgn := x / abs(x)
end;

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

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

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

function myarcsin(x, y: real): real;
begin
  if x = 1 then
    myarcsin := pi / 2
  else
    myarcsin := arctan(x / sqrt(1 - sqr(x)))
end;

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

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

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

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

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

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

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

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

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

function myodd(x, y: real): real;
begin
  if odd(trunc(x)) then
    myodd := 1
  else
    myodd := 0;
end;

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

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

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

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

function myfac(x, y: real): real;
var
  n: integer;
  r: real;
begin
  if x < 0 then
  begin
    writeln(' Немогу вычислить факториал ');
    halt;
  end;
  if x = 0 then
    myfac := 1
  else
  begin
    r := 1;
    for n := 1 to trunc(x) do
      r := r * n;
    myfac := r;
  end;
end;

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

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

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

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

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

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

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

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

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

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

constructor evalobj.init(st: string);
var
  st2, st3: string;
  error: integer;
begin
  f1 := nil;
  f2 := nil;
  analyse(st, st2, st3);
  f3 := analysetmp;
  val(st2, f1x, error);
  if st2 = '' then
  begin
    f1x := 0;
    error := 0;
  end;
  if error <> 0 then
    new(f1, init(st2));
  val(st3, f2y, error);
  if st3 = '' then
  begin
    f2y := 0;
    error := 0;
  end;
  if error <> 0 then
    new(f2, init(st3));
end;

destructor evalobj.done;
begin
  if f1 <> nil then
    dispose(f1, done);
  if f2 <> nil then
    dispose(f2, done);
end;

end.


Source: http://delphiworld.narod.ru/
ID: 04230



Компонент разбора формул[править | править код]

unit MathComponent;

interface

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

type
  TMathType = (mtNil, mtOperator, mtLBracket, mtRBracket, mtOperand);

type
  TMathOperatorType = (moNone, moAdd, moSub, moDiv, moMul, moPow);

type
  PMathChar = ^TMathChar;
  TMathChar = record
  case MathType: TMathType of
    mtOperand:(data: Extended);
    mtOperator:(op: TMathOperatorType);
  end;

type
  TMathControl = class(TComponent)
  private
    input, output, stack: array of TMathChar;
    FMathString: string;
    function GetResult: Extended;
    function Calculate(Operand1, Operand2, AOperator: TMathChar): Extended;
    function GetOperator(c: Char): TMathOperatorType;
    function GetOperand(mid: Integer; var len: Integer): Extended;
    procedure ProcessString;
    procedure ConvertInfixToPostfix;
    function IsDigit(c: Char): Boolean;
    function IsOperator(c: Char): Boolean;
    function GetPrecedence(mop: TMathOperatorType): Integer;
  published
    property MathExpression: string read FMathString write FMathString;
    property MathResult: Extended read GetResult;
  end;

procedure register;

implementation

function TMathControl.Calculate(Operand1, Operand2, AOperator: TMathChar): Extended;
begin
  Result := 0;
  case operator.op of
    moAdd:
      Result := Operand1.data + Operand2.data;
    mosub:
      Result := Operand1.data - Operand2.data;
    momul:
      Result := Operand1.data * Operand2.data;
    modiv:
      if (Operand1.data <> 0) and (Operand2.data <> 0) then
        Result := Operand1.data / Operand2.data
      else
        Result := 0;
    mopow:
      Result := Power(Operand1.data, Operand2.data);
  end;
end;

function TMathControl.GetResult: Extended;
var
  i: Integer;
  tmp1, tmp2, tmp3: TMathChar;
begin
  ConvertInfixToPostfix();
  SetLength(stack, 0);
  for i := 0 to Length(output)-1 do
  begin
    if output[i].MathType = mtOperand then
    begin
      SetLength(stack, Length(stack)+1);
      stack[Length(stack)-1] := output[i];
    end
    else
    if output[i].MathType = mtOperator then
    begin
      tmp1 := stack[Length(stack)-1];
      tmp2 := stack[Length(stack)-2];
      SetLength(stack, Length(stack)-2);
      tmp3.MathType := mtOperand;
      tmp3.data := Calculate(tmp2, tmp1, output[i]);
      SetLength(stack, Length(stack)+1);
      stack[Length(stack)-1] := tmp3;
    end;
  end;
  Result := stack[0].data;
  SetLength(stack, 0);
  SetLength(input, 0);
  SetLength(output, 0);
end;

function TMathControl.GetOperator(c: Char): TMathOperatorType;
begin
  Result := moNone;
  if c = '+' then
    Result := moAdd
  else if c = '*' then
    Result := moMul
  else if c = '/' then
    Result := moDiv
  else if c = '-' then
    Result := moSub
  else if c = '^' then
    Result := moPow;
end;

function TMathControl.GetOperand(mid: Integer; var len: Integer): Extended;
var
  i, j: Integer;
  TmpNum: string;
begin
  j := 1;
  for i := mid to Length(FMathString)-1 do
  begin
    if IsDigit(FMathString[i]) then
    begin
      if j <= 20 then
        TmpNum := TmpNum + FMathString[i];
      j := j + 1;
    end
    else
      Break;
  end;
  Result := StrToFloat(TmpNum);
  len := Length(TmpNum);
end;

procedure TMathControl.ProcessString;
var
  i:  Integer;
  NumLen: Integer;
begin
  i := 0;
  NumLen := 0;
  SetLength(output, 0);
  SetLength(input, 0);
  SetLength(stack, 0);
  FMathString := '(' + FMathString + ')';
  SetLength(input, Length(FMathString));
  while i <= Length(FMathString)-1 do
  begin
    if FMathString[i+1] = '(' then
    begin
      input[i].MathType := mtLBracket;
      i := i + 1;
    end
    else
    if FMathString[i+1] = ')' then
    begin
      input[i].MathType := mtRBracket;
      i := i + 1;
    end
    else
    if IsOperator(FMathString[i+1]) then
    begin
      input[i].MathType := mtOperator;
      input[i].op := GetOperator(FMathString[i+1]);
      i := i + 1;
    end
    else
    if IsDigit(FMathString[i+1]) then
    begin
      input[i].MathType := mtOperand;
      input[i].data := GetOperand(i+1, NumLen);
      i := i + NumLen;
    end;
  end;
end;

function TMathControl.IsOperator(c: Char): Boolean;
begin
  Result := False;
  if (c = '+') or (c = '-') or (c = '*') or (c = '/') or (c = '^') then
    Result := True;
end;

function TMathControl.IsDigit(c: Char): Boolean;
begin
  Result := False;
  if ((Integer(c) > 47) and (Integer(c) < 58)) or (c = '.') then
    Result := True;
end;

function TMathControl.GetPrecedence(mop: TMathOperatorType): Integer;
begin
  Result := -1;
  case mop of
    moAdd: Result := 1;
    moSub: Result := 1;
    moMul: Result := 2;
    moDiv: Result := 2;
    moPow: Result := 3;
  end;
end;

procedure TMathControl.ConvertInfixToPostfix;
var
  i, j, prec: Integer;
begin
  ProcessString();
  for i:=0 to Length(input)-1 do
  begin
    if input[i].MathType = mtOperand then
    begin
      SetLength(output, Length(output)+1);
      output[Length(output)-1] := input[i];
    end
    else
    if input[i].MathType = mtLBracket then
    begin
      SetLength(stack, Length(stack)+1);
      stack[Length(stack)-1] := input[i];
    end
    else
    if input[i].MathType = mtOperator then
    begin
      prec := GetPrecedence(input[i].op);
      j := Length(stack)-1;
      if j >= 0 then
      begin
        while(GetPrecedence(stack[j].op) >= prec) and (j >= 0) do
        begin
          SetLength(output, Length(output)+1);
          output[Length(output)-1] := stack[j];
          SetLength(stack, Length(stack)-1);
          j := j - 1;
        end;
        SetLength(stack, Length(stack)+1);
        stack[Length(stack)-1] := input[i];
      end;
    end
    else
    if input[i].MathType = mtRBracket then
    begin
      j := Length(stack)-1;
      if j >= 0 then
      begin
        while(stack[j].MathType <> mtLBracket) and (j >= 0) do
        begin
          SetLength(output, Length(output)+1);
          output[Length(output)-1] := stack[j];
          SetLength(stack, Length(stack)-1);
          j := j - 1;
        end;
        if j >= 0 then
          SetLength(stack, Length(stack)-1);
      end;
    end;
  end;
end;

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

end.


Source: http://delphiworld.narod.ru/
ID: 04231



Функция вычисления простых выражений[править | править код]

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

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

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

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

  function Expression: Real;
  var
    w: Real;

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

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


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


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