Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

Курс видеоуроков КРЭКЕРСТВО + ПРОГРАММИРОВАНИЕ 2017
(актуальность: май 2017)
Свежие инструменты, новые видеоуроки!

  • 400+ видеоуроков
  • 800 инструментов
  • 100+ свежих книг и статей

УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



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

Программер живет на 12 этаже. После работы входит к себе в подъезд, заходит в лифт, нажимает 1, потом 2, а потом судорожно ищет клавишу "Enter"...

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




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS