В этом выпуске речь пойдет о вычислении выражений, заданных строкой. Этот алгоритм основан на бинарном дереве и является одним из самых быстрых. Смысл алгоритма в том, что каждая операция проводится над одним или двумя числами. Например: (1+2)*3 - умножается сумма на 3, сумма - складываются 1 и 2. 1+2+3 тоже можно представить, как (1+2)+3, то есть сумму суммы 1 и 2 с 3. Таким образом, каждая операция выполняется над одной или двумя операциями (число здесь рассматривается как операция, возвращающая значение этого числа). Можно написать функцию (назовем ее Count), которая бы выполняла заданную операцию с двумя заданными подоперациями. Причем, чтобы вычислить значения подопераций, эта функция будет вызывать себя же. Например: Count(1+2) = Count(1) + Count(2). Или: Count(1*2+3*4) = Count(1*2) + Count(3*4) = Count(Count(Count(1) * Count(2)) + Count(Count(3) * Count(4))). Если значение выражения нужно посчитать несколько раз (подставляя разный x), удобно один раз разобрать выражение по бинарному дереву, а потом уже с большой скорость вычислять. Для этого нужно создать рекуррентную структуру, то есть каждая операция содержит одну или две подоперации. В свою очередь каждая подоперация содержит свои подоперации и т.д.

Теперь о реализации. Тип TOperation определя операцию (+, -, *, ...). Запись TTreeTop - это и есть операция с подоперациями. Конструкция case позволяет для разных операций хранить разные поля, не затрачивая лишней памяти. Если операция - число, в записи хранится это число, если x - хранится адрес переменной x. Такой подход позволяет наиболее удобно подсталять различные значения x. OperStr - это строковые аналоги операций (плюс - '+', синус - 'sin' и т.д.). OperPr - это приоритет операций. LastOper - последняя операция данного приоритета. FillTree ищет справа налево операцию с наименьшем приоритетом. Эта операция должна находиться вне скобок. Поэтому заведен счетчик открытых-закрытых скобок, а в начале процедуры из строки удаляются лишние скобки. Как работает Count было рассказано выше. Единственное, что о чем здесь нужно еще сказать, это об особенности дебаггера Delphi. Когда Вы запускаете программу из-под Delphi, дебаггер, несмотря на предусмотренную Вами обработку исключений try-except, при каждой ошибке выдает свое сообщение. Эта проблема исчезает, когда Вы запускаете программу другим способом (например, из Проводника). Также существует возможность выключить эту функцию. Для этого нужно выключить флажок Integrating Debugging (в Delphi3 он находится Tools|Enviroment Options|Preferences|Debugging, а в Delphi5 Tools| Option|Debugger Options).

Button1 строит график y=f(x) - f(x) задается в Edit1. Button2 проводит миллион вычислений f(x) и выводит затраченное время в заголовок окна.

Скачать необходимые для компиляции файлы проекта можно на program.dax.ru. Достапны проекты для различных версий Delphi.

uses Math;

{ Эта функция скопирована из модуля SysUtils пятого
  Delphi. Необходима в более ранних версиях Delphi: }
function AnsiSameText(const S1, S2: string): Boolean;
begin
  result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE,
    PChar(S1), length(S1), PChar(S2), length(S2)) = 2;
end;

type
  pdouble = ^double;
  TOperation = (opValue, opX, opUnMinus, opPlus, opMinus, opMultiply, opDivide,
    opPower, opSin, opCos, opTg, opArcsin, opArccos, opArctg,
    opInt, opAbs);
  PTreeTop = ^TTreeTop;
  TTreeTop = record
    case operation: TOperation of
      opValue: (v: double);
      opX: (xaddr: pdouble);
      opPlus, opMinus, opMultiply, opDivide, opPower: (left, right: PTreeTop);
      opUnMinus, opSin, opCos, opTg, opArcsin, opArccos, opArctg, opInt, opAbs: (arg: PTreeTop);
  end;

const
  OperStr: array [opPlus..opAbs] of string = ('+', '-', '*', '/', '^',
    'sin', 'cos', 'tg', 'arcsin', 'arccos', 'arctg', 'int', 'abs');
  OperPr: array [opUnMinus..opAbs] of integer = (1, 1, 1, 2, 2,
    3, 4, 4, 4, 4, 4, 4, 4, 4);
  LastOper: array [1..5] of TOperation = (opX, opMinus, opDivide,
    opPower, opAbs);

// Удаление лишних скобок, например: "((1+2)+3)" -> "(1+2)+3"
procedure DeleteBrackets(var s: string);
var i, br, min: integer;
begin
  if length(s) <= 0 then Exit;
  s := trim(s); // Удаление из начала и конца строки пробелов
  min := length(s); // Заведомо больше
  br := 0;
  for i := 1 to length(s) do
    case s[i] of
      '(': inc(br);
      ')': dec(br);
      else if (s[i] <> ' ') and (min > br) then min := br;
    end;
  // Удаление из строки первых и последних min символов
  s := trim(copy(s, min + 1, length(s) - min * 2));
end;

procedure FillTree(top: PTreeTop; s: string; XAddr: pdouble);
var
  op, oper: TOperation;
  i, code, MinPrior, OperPos, br: integer;
begin
  DeleteBrackets(s); // Удаление лишних скобок
  oper := opValue;
  OperPos := 1;
  MinPrior := 5;
  br := 0;
  // Поиск операции:
  for i := length(s) downto 1 do
    case s[i] of
      ')': inc(br);
      '(': dec(br);
      else if br = 0 then { Если количество открытых скобок равно
                            количеству закрытых скобок: }
        for op := opUnMinus to LastOper[MinPrior] do begin
          { Сравнение куска текста с операцией без учета регистра: }
          if (AnsiSameText(copy(s, i, length(OperStr[op])),
            OperStr[op]))
          then begin
            MinPrior := OperPr[op];
            oper := op;
            OperPos := i;
            break;
          end;
      end;
    end;
  // Если нужно - из минуса сделать унарный минус:
  if (oper = opMinus) and (OperPos = 1) then oper := opUnMinus;
  case oper of
    // операции одного аргумента:
    opUnMinus, opSin..opInt:
    begin
      new(top^.arg);
      inc(OperPos, length(OperStr[oper]));
      FillTree(top^.arg, copy(s, OperPos, length(s) - OperPos + 1), XAddr);
    end;
    // операции двух аргументов:
    opPlus, opMinus, opMultiply, opDivide, opPower:
    begin
      new(top^.left);
      FillTree(top^.left, copy(s, 1, OperPos - 1), XAddr);
      new(top^.right);
      inc(OperPos, length(OperStr[oper]));
      FillTree(top^.right, copy(s, OperPos, length(s) - OperPos + 1), XAddr);
    end;
    else begin
      if LowerCase(s) = 'x' then begin // x
        oper := opX;
        top^.operation := opX;
        top^.XAddr := XAddr;
      end else begin // Число
        oper := opValue;
        top^.operation := opValue;
        val(s, top^.v, code);
      end;
    end;
  end;
  top^.operation := oper;
end;

// Освобождение памяти:
procedure FreeTree(top: PTreeTop);
begin
  case top^.operation of
    opPlus, opMinus, opMultiply, opDivide, opPower: begin
      FreeTree(top^.left);
      FreeTree(top^.right);
    end;
    opUnMinus, opSin, opCos, opTg, opArcsin, opArccos,
      opArctg, opInt, opAbs: FreeTree(top^.arg);
  end;
  dispose(top);
end;

// Вычисление выражения:
function Count(top: PTreeTop; var error: boolean): double; register;
var y: double;
begin
  try
    case top^.operation of
      opX: result := top^.XAddr^;
      opUnMinus: result := -Count(top^.arg, error);
      opPlus: result := Count(top^.left, error) + Count(top^.right, error);
      opMinus: result := Count(top^.left, error) -
        Count(top^.right, error);
      opMultiply: result := Count(top^.left, error) *
        Count(top^.right, error);
      opDivide: result := Count(top^.left, error) /
        Count(top^.right, error);
      opPower: begin
        y := Count(top^.right, error);
        if abs(round(y) - y) < 1E-10
          then result := IntPower(Count(top^.left, error), round(y))
          else result := Power(Count(top^.left, error), y);
      end;
      opSin: result := sin(Count(top^.arg, error));
      opCos: result := cos(Count(top^.arg, error));
      opTg: result := tan(Count(top^.arg, error));
      opArcsin: result := arcsin(Count(top^.arg, error));
      opArccos: result := arccos(Count(top^.arg, error));
      opArctg: result := arctan(Count(top^.arg, error));
      opInt: result := int(Count(top^.arg, error));
      opAbs: result := abs(Count(top^.arg, error));
      else result := top^.v;
    end;
  except // Проихошла ошибка:
    result := 0;
    error := true;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  left = -15; // Наименьший x
  right = 15; // Наибольший x
  k = 10; // Колиство точек на пиксел экрана
var
  x, y: double;
  i: integer;
  error: boolean;
  top: PTreeTop;
  Scale: single;
begin
  //5*cos(2*x)+12*sin(2*x)-12*sin(x)-18*cos(x)+17
  new(top); // Выделение памяти под главную вершину
  FillTree(top, Edit1.Text, @x); // Заполнение бинарного дерева
  Scale := Image1.Width / (right - left); // Вычисление масштаба
  // Вывод осей:
  with Image1.Canvas do begin
    Rectangle(0, 0, Image1.Width, Image1.Height);
    MoveTo(round(-left * Scale), Image1.Height);
    LineTo(round(-left * Scale), 0);
    MoveTo(0, Image1.Height div 2);
    LineTo(Image1.Width, Image1.Height div 2);
  end;
  error := false;
  for i := round(left * Scale * k) to round(right * Scale * k) do begin
    x := i / Scale / k; { В ячейку памяти с x
                          кладем значение аргумента }
    y := Count(top, error); // Вычисление выражения
    if error // Если ошибка:
      then error := false // Восстановить значение флага
      // Иначе рисуется точка:
      else Image1.Canvas.Pixels[(round(i / k - left * Scale)),
        round(Image1.Height / 2 - y * Scale)] := clRed;
  end;
  FreeTree(top);
end;

{$HINTS OFF} { Поскольку это тестирующая процедура,
               предупреждения здесь не нужны }
procedure TForm1.Button2Click(Sender: TObject);
var
  x, y: double;
  i: integer;
  error: boolean;
  top: PTreeTop;
  t: cardinal;
begin
  new(top); // Выделение памяти под главную вершину
  FillTree(top, Edit1.Text, @x); // Заполнение бинарного дерева
  t := GetTickCount; // Засечение времени
  for i := 1 to 1000000 do
    y := Count(top, error); // Вычисление выражения
  Form1.Caption := IntToStr(GetTickCount - t); // Вывод времени
  FreeTree(top); // Освобождение памяти
end;
{$HINTS ON}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if AnsiSameText(Edit1.Text, Edit2.Text)
    then Form1.Caption := 'same'
    else Form1.Caption := 'different';
end;

Всего доброго,
Даниил Карапетян.

Тематические ссылки

Ваша ссылка

Ваша ссылка

Обмен кнопками, ведение статистики, реклама.