Расчет введенной формулы

Поговорим о том, как можно рассчитать выражение, заданное в строке (string).
Иногда в программе удобно сделать так, чтобы пользователь мог ввести функцию, а программа строила бы по ней график или высчитывала какое-то значение.
Если нужно многократно вычислить одно и то же выражение с разным аргументом (например, для рисования графика) лучше выделить в отдельную процедуру проверку правильности выражения, преобразования строки к удобному виду и т.д.
Наиболее простой способ посчитать значение выражения, это выполнять все операции, начиная с операций высшего приоритета, заменяя задействованные числа и знаки на результат вычислений. Например, выражение "1+2*3^4/5" этот алгоритм начнет рассчитывать с возведения 3 в степень 4. Символы "3^4" уже не нужны и они заменяются на получившийся результат. Получается: "1+2*81/5". Дальше нужно произвести умножение 2 на 81 и т.д.
Перед вычислением нужно убрать все пробелы из строки, заменить все точки и запятые на стандартный разделитель - DecimalSeparator. Помимо этого все символы переводятся на нижний регистр, заменяются некоторые константы, знак ":" заменяется на "/", а модуль, записанный символами "|" заменяется на функцию "abs". Для различия между отрицательным числом и знаком вычитания и для упрощения алгоритма каждое число окружается символами #.
Чтобы можно было вычислить значения выражения с аргументами, перед каждым вычислением нужно вызывать функцию ChangeVar.
Здесь приведен модуль с этими тремя функциями и пример их использования.

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 false;

end;

function Recogn(st: String; var num: extended): boolean;

const

 pogr = 1E-10;

var

 p, p1: integer;

 i, j: integer;

 v1, v2: extended;

 func: (fNone, fSin, fCos, fTg, fCtg, fArcsin, fArccos, fArctg, 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, 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('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: 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);

  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.

Эта программа строит заданные графики, используя модуль Recognition. От констант left и right зависит диапазон x, от YScale зависит масштаб по y, а от k зависит качество прорисовки.

uses Recognition;

procedure TForm1.Button1Click(Sender: TObject);

const

 left = -10;

 right = 10;

 YScale = 50;

 k = 10;

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 * k) to round(right * XScale * k) do

  if recogn(ChangeVar(s, 'x', i / XScale / k), Num) then

  PaintBox1.Canvas.Pixels[round(i / k - left * XScale),

  round(PaintBox1.Height / 2 - Num * YScale)] := col;

end;

Рекомендую так же использовать для этих целей модуль Parsing из RxLib или JVCL
Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)

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

Проверка
Антиспам проверка
Image CAPTCHA
...