На главную

Посчитать строку с формулой

Посчитать строку с формулой

ОГЛАВЛЕНИЕ    HOME  MAIL



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

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

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

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

unit Recognition;

interface

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

type
  TVar = set of char;

procedure Preparation(var s: String; variables: TVar);
function ChangeVar(s: String; c: char; value: extended): String;
function Recogn(st: String; var Num: extended): boolean;

implementation


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

// " "
  repeat
    i := pos(' ', s);
    if i <= 0 then break;
    delete(s, i, 1);
  until 1 = 0;

  s := LowerCase(s);

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

// Pi
  repeat
    i := pos('pi', s);
    if i <= 0 then break;
    delete(s, i, 2);
    insert(FloatToStr(Pi), s, i);
  until 1 = 0;

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

// |...|
  repeat
    i := pos('|', s);
    if i <= 0 then break;
    s[i] := 'a';
    insert('bs(', s, i + 1);
    i := i + 3;
    repeat i := i + 1 until (i > Length(s)) or (s[i] = '|');
    if s[i] = '|' then s[i] := ')';
  until 1 = 0;

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

function ChangeVar(s: String; c: char; value: extended): String;
var
  p: integer;
begin
  result := s;
  repeat
    p := pos(c, result);
    if p <= 0 then break;
    delete(result, p, 1);
    insert(FloatToStr(value), result, p);
  until 1 = 0;
end;

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

  function FindLeftValue(p: integer; var Margin: integer; var Value: extended): boolean;
  var
    i: integer;
  begin
    i := p - 1;
    repeat i := i - 1 until (i <= 0) or (s[i] = '#');
    Margin := i;
    try
      Value := StrToFloat(copy(s, i + 1, p - i - 2));
      result := true;
    except
      result := false
    end;
    delete(s, i, p - i);
  end;

  function FindRightValue(p: integer; var Value: extended): boolean;
  var
    i: integer;
  begin
    i := p + 1;
    repeat i := i + 1 until (i > Length(s)) or (s[i] = '#');
    i := i - 1;
    s1 := copy(s, p + 2, i - p - 1);
    result := TextToFloat(PChar(s1), value, fvExtended);
    delete(s, p + 1, i - p + 1);
  end;

  procedure PutValue(p: integer; NewValue: extended);
  begin
    insert('#' + FloatToStr(v1) + '#', s, p);
  end;

begin
  Result := false;
  s := st;

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

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

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

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

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

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

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

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

  Result := true;
end;

end.

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

uses Recognition;

procedure TForm1.Button1Click(Sender: TObject);
const
  left = -10;
  right = 10;
  YScale = 50;
var
  i: integer;
  Num: extended;
  s: String;
  XScale: single;
  col: TColor;
begin
  s := Edit1.Text;
  preparation(s, ['x']);
  XScale := PaintBox1.Width / (right - left);
  randomize;
  col := RGB(random(100), random(100), random(100));
  for i := round(left * XScale) to round(right * XScale) do
    if recogn(ChangeVar(s, 'x', i / XScale), Num) then
      PaintBox1.Canvas.Pixels[round(i - left * XScale),
        round(PaintBox1.Height / 2 - Num * YScale)] := col;
end;

главная страницаоглавлениезадать вопрос
email: delphi4all@narod.ru
Hosted by uCoz