Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Преобразование выражения к Обратной Польской Нотации

01.01.2007
{ **** UBPFD *********** by kladovka.net.ru ****
>> Преобразование выражения к Обратной Польской Нотации
 
Для работы функции необходимо определить тип:
type
OperList = array of widestring;
 
Параметром функции служит массив из переменных и операторов.
Результат - массив из переменных и операторов
 
Зависимости: SysUtils
Автор:       avr555, avr555@mail.ru, ICQ:15782989
Copyright:   Переделано с http://algolist.manual.ru/syntax/revpn.php
Дата:        26 мая 2002 г.
********************************************** }
 
function ConvertToRPN(AStr:OperList):OperList;
var
  i
,k:integer;
 
Stack : OperList; //Stack
 
AResult : OperList; //Tmp for result
 
 
function Prior(AOper:widestring):integer;
 
begin
   
{Приоритет операции:
 
      NOT
- 8
     
унарный "-" - 7
     
"*", "/" - 6
     
"+", "-" - 5
     
">", "<", "=",
     
"<>", ">=",
     
"<=" - 4
     
"AND" - 3
     
"OR" - 2
     
"(", ")" - 1
   
}
 
   
AOper := trim(AOper);
    result
:= -1;
 
   
if AOper = 'NOT' then Result := 8;
   
if (AOper = '*') or (AOper = '/') then Result := 6;
   
if (AOper = '+') or (AOper = '-') then Result := 5;
   
if (AOper = '>') or (AOper = '<') or (AOper = '<>') or (AOper = '>=')
     
or (AOper = '<=') or (AOper = '=') then Result := 4;
 
   
if AOper = 'AND' then Result := 3;
   
if AOper = 'OR' then Result := 2;
   
if (AOper = '(') or (AOper = ')') then Result := 1;
 
end;
 
  procedure
AddToStack(AOper:widestring);
 
begin
   
{Добавление элементы в стек}
   
SetLength(Stack,High(Stack)+2);
   
Stack[High(Stack)] := AOper;
 
end;
 
  procedure
AddToResult(AOper:widestring);
 
begin
   
SetLength(AResult,High(AResult)+2);
   
AResult[High(AResult)] := AOper;
 
end;
 
begin
 
{Конвертирование строку в Обратную Польскую Нотацию
   
Возвращает - массив
 
   
Алгоритм:
     
а) если стек пуст, то опеpация из входной стpоки пеpеписывается в стек;
     
б) опеpация выталкивает из стека все опеpации с большим или pавным
         
пpиоpитетом в выходную стpоку;
     
в) если очеpедной символ из исходной стpоки есть откpывающая скобка,
         
то он пpоталкивается в стек;
     
г) закpывающая кpуглая скобка выталкивает все опеpации из стека до
         
ближайшей откpывающей скобки, сами скобки в выходную стpоку не
         
пеpеписываются, а уничтожают дpуг дpуга.
 
}
 
Result := nil;
 
AResult := nil;
  i
:= 0;
 
while i <= High(AStr) do
 
begin
   
if Prior(AStr[i]) = -1 then //Значит просто переменная
       
AddToResult(AStr[i])
   
else //Операции
   
begin
     
if High(Stack) = -1 then {a}
       
AddToStack(AStr[i])
     
else
     
begin
       
if AStr[i] = '(' then {в}
         
AddToStack(AStr[i])
       
else
       
begin
 
         
if AStr[i] = ')' then {г}
         
begin
            k
:= High(Stack);
           
while (k>=0) and (Stack[k] <> '(') do
           
begin
             
AddToResult(Stack[k]);
             
SetLength(Stack,High(Stack)); //Удаляем элемент из стека
              k
:= k - 1;
           
end;
           
//Удаляем открывающуюся скобку
           
SetLength(Stack,High(Stack)); //Удаляем элемент из стека
 
         
end
         
else
         
begin
            k
:= High(Stack);
           
while (k>=0) and (Prior(Stack[k]) >= Prior(AStr[i])) do {б}
           
begin
             
AddToResult(Stack[k]);
             
SetLength(Stack,high(Stack)); //Удаляем элемент из стека
              k
:= k - 1;
           
end;
           
AddToStack(AStr[i]); //Если не скобка просто добавляем в стек
         
end;
       
end;
 
     
end;
 
   
end;
 
    i
:= i + 1;
 
end; //while
 
//Сбрасываем все оставшееся из стека
 
for i := high(Stack) downto 0 do
 
begin
   
AddToResult(Stack[i]);
 
end;
 
  result
:= AResult;
end;

Пример использования:

procedure test;
var
  s
,s1:widestring;
  tmp
,
  rtmp
: OperList;
  i
:integer;
begin
  s
:= '(A+B)*(C+D)-E';
  tmp
:= nil;
  rtmp
:= nil;
 
 
for i:= 1 to Length(S) do
 
begin
   
SetLength(tmp, high(tmp)+2);
    tmp
[high(tmp)] := S[i];
 
end;
  rtmp
:= ConvertToRPN(tmp);
  s1
:= '';
 
 
for i := 1 to High(rtmp) do
 
begin
    s1
:= s1 + rtmp[i];
 
end;
end;