unit Synt;

interface

uses classes;

type
 { Тип записи с именем и значением
   переменной или именованной константы }
 TData = record
   Name: string;
   Data:real;
 end;

var
 // Максимальное количество числовых констант
 NConst: integer = 100;

 // Массив сообщений об ошибках
 ErrorList: TStringList;

 // Массив польской записи
 PZ: array of integer;

 // Массив значений и имен переменных и именованных констант
 DataList: array of TData;

const
 // число предопределенных констант
 MConst = 2;

{Чтение очередной лексемы в тексте S,
 начиная c позиции Pos. First - начинается ли чтение,
 или продолжается}
procedure SyntItem(S:string; First:boolean=false; Pos:Integer=1);

{Формирование польской записи поочередным чтением
 лексем из текста S}
function CreatePZ(S:string):boolean;

{Расчет по польской записи}
function Calculate(var R:real):boolean;

{Задание переменной Name значения Data}
function SetData(Name:string; Data:real):boolean;

{Получение значения переменной Name}
function GetData(Name:string; var Data:real):boolean;

implementation

uses Sysutils, Math, Dialogs;

type
 // Тип лексем
 TType = (None, Number, Divider, Ident, Func, Part, All);

 // Тип записи с характеристиками прочитанной лексемы
 TSynt = record
    mode: TType;       // Тип лексемы
    Number:real;       // Число, если лексема -
                       // числовая константа
    Ident:string;      // Идентификатор или символ операции
    Error:boolean;     // Обнаружена ли ошибка
    Pos1,Pos2:integer; // Позиции начала и конца
                       // лексемы в тексте
 end;

const
    // Множество символов, используемых при записи числа
    SetNum: set of char=['0'..'9', ','];

    // Множество символов - разделителей
    SetDiv: set of char=[';', '(', ')', '=', '+', '-', '/', '*', '^',
                         '{', ' ', #13];

    {Множество символов, используемых при записи идентификаторов}
    SetChar: set of char=['a'..'z','A'..'Z','_'];

    // Число различных функций
    NFunc = 9;

    // Массив идентификаторов функций
    Functions: array[1..NFunc] of string =
      ('exp','sin','cos','sqrt','abs','ln','tg','arctg','arccos');

var
  {Переменная, содержащая характеристику прочитанной лексемы}
 SItem: TSynt;

 // Стек, используемый при трансляции
 TrStack: array of char;

 // Массив числовых констант
 ConstList: array of real;

 // Текущая позиция трансляции
 Position: Integer;

procedure SyntItem(S:string;First:boolean=false;Pos:Integer=1);
// Распознавание синтаксических элементов строки S
// First=true указывает на первое обращение
// Pos - позиция в строке при первом обращении
var i:integer;

begin
 if (S = '') then begin
  SItem.mode := All;
  exit;
 end;
// Если первое обращение,
// то Position = Pos (заданному значению или 1)
 if(First) then Position := Pos;

// Пропуск комментариев и пробельных символов
 repeat
// Пропуск комментариев
  if (S[Position] = '{')
   then begin
    repeat
     Inc(Position)
    until (Position >= Length(S)) or (S[Position] = '}');
    Inc(Position);
   end;
// Пропуск пробелов и переводов строки
  if(Position <= Length(S)) then
   while ((S[Position] = ' ')or
          (S[Position] = #13)or
          (S[Position] = #10)or
          (S[Position] = #0))
   do Inc(Position);
 until (S[Position] <> '{');

 SItem.Error:=false;
 SItem.Pos1:=Position;

// Если Position > длины строки, то уход и mode = All
 if(Position > Length(S)) then begin
  SItem.mode := All;
  exit;
 end;

// Занесение текущего символа в Ident
 SItem.Ident := S[Position];
 if (S[Position] in SetChar)
     // Идентификатор
     then SItem.mode := Ident
 else if (S[Position] in SetNum)
     // Число
     then SItem.mode := Number
 else if (S[Position] in SetDiv)
     then begin
      // Разделитель
      if (S[Position] <> ';')
       then SItem.mode := Divider
       else SItem.mode := Part;
      // Переход к следующей позиции
      Inc(Position);
      // Выход
      exit;
     end
     // Неизвестный символ
 else begin
  SItem.mode := None;
  Inc(Position);
  exit;
 end;

 // Продолжение ввода
 repeat
  // Переход к следующей позиции
  Inc(Position);
  if (SItem.mode = Number)and
     ((S[Position] = '-')or(S[Position] = '+'))and
     (UpCase(S[Position-1])='E')
    then SItem.Ident := SItem.Ident + S[Position]
  else if ((Position > Length(S))or(S[Position] in SetDiv))
    then begin
    // Окончание идентификатора или числа
     if(SItem.mode = Number)
       then try
         SItem.Number := StrToFloat(SItem.Ident)
       except
        // Перехват исключения при ошибочном числе
        on EConvertError do SItem.Error := true;
       end;
    // Проверка, соответствует ли идентификатор функции
     for i:=1 to NFunc do
      if (LowerCase(SItem.Ident) = Functions[i])
        then begin
         SItem.mode:=Func;
         SItem.Number:=i;
         break;
        end;
     // Выход
     SItem.Pos2:=Position-1;
     exit;
    end
    // Продолжение формирования идентификатора или числа
    else SItem.Ident := SItem.Ident + S[Position];
 // Бесконечный цикл
 until false;
end;

procedure ClearPZ;
// Очистка польской записи
begin
 ErrorList.Clear;
 SetLength(ConstList,0);
 SetLength(DataList,MConst);
 SetLength(PZ,0);
end;

function CreatePZ(S:string):boolean;
// Формирование польской записи
var
    {Флаг завершения операций при конце формирования записи выражения:}
    lend:boolean;
    i:integer;
    Assign:boolean; // Допустимость операции =
    Adress: integer; // Адрес пересылки результата
    OldMode: TType;  // Характер предыдущей лексемы
    OldS: char;      // Первый символ предыдущей лексемы
procedure code;
// Запись в стек кода арифметической операции
begin
 SetLength(PZ,High(PZ)+2);
 case TrStack[High(TrStack)] of
  '+': PZ[High(PZ)] := -1;
  '-': PZ[High(PZ)] := -2;
  '*': PZ[High(PZ)] := -3;
  '/': PZ[High(PZ)] := -4;
  '^': PZ[High(PZ)] := -5;
  'M': PZ[High(PZ)] := -6;
 end;
end;

procedure proc1;
begin
 SetLength(TrStack,High(TrStack)+2);
 TrStack[High(TrStack)] := SItem.Ident[1];
end;

procedure proc2;
begin
 code;
 TrStack[High(TrStack)] := SItem.Ident[1];
end;

procedure proc3;
begin
 code;
 SetLength(TrStack,High(TrStack));
 lend:=false;
end;

procedure proc4;
begin
 SetLength(TrStack,High(TrStack));
end;

procedure proc5;
// Аналог proc1 для функций
begin
 SetLength(TrStack,High(TrStack)+2);
 TrStack[High(TrStack)] := Chr(127+Round(SItem.Number));
end;

procedure proc6;
// Аналог proc3 для функций
begin
 SetLength(PZ,High(PZ)+2);
 PZ[High(PZ)] := -Ord(TrStack[High(TrStack)])+27;
 SetLength(TrStack,High(TrStack));
end;

begin
 ClearPZ;
 SetLength(TrStack,1);
 TrStack[0] := '0';
 OldMode := None;
 OldS := ' ';
 Assign := true;
 Adress := 0;
 // Чтение первой лексемы
 SyntItem(S,true);
 if (SItem.mode = All)
  then begin
   ErrorList.Add('Не введено никакого текста');
   Result := false;
   exit;
  end;
 repeat
  if ((OldMode = Func)and(SItem.Ident[1] <> '('))
   then ErrorList.Add('Пропущена скобка после функции в позиции '+IntToStr(SItem.Pos1));
  case SItem.mode of
   Number: begin
            if((OldMode <> Divider)and(OldMode <> None)and
               (OldMode <> Part))
             then ErrorList.Add('В позиции '+IntToStr(SItem.Pos1)+' должен быть разделитель');
            if (SItem.Error)
             then ErrorList.Add('Ошибка в позициях '+IntToStr(SItem.Pos1)+
                                ' - '+IntToStr(SItem.Pos2))
             else begin
              SetLength(ConstList,High(ConstList)+2);
              ConstList[High(ConstList)] := SItem.Number;
              SetLength(PZ,High(PZ)+2);
              PZ[High(PZ)] := High(ConstList);
             end;
            Assign:=false;
           end;
   Ident:  begin
            if((OldMode <> Divider)and(OldMode <> None)and
               (OldMode <> Part))
             then ErrorList.Add('В позиции '+IntToStr(SItem.Pos1)+' должен быть разделитель');
            for i:=0 to High(DataList) do
             begin
              if (UpperCase(SItem.Ident) = DataList[i].Name)
               then begin
                SetLength(PZ,High(PZ)+2);
                PZ[High(PZ)] := NConst+i;
                break;
               end;
              if(i = High(DataList)) then
               begin
                SetLength(DataList,High(DataList)+2);
                DataList[High(DataList)].Name:=UpperCase(SItem.Ident);
                DataList[High(DataList)].Data:=0;
                SetLength(PZ,High(PZ)+2);
                PZ[High(PZ)] := NConst+High(DataList);
               end;
             end;
            end;
   All,Part:begin
            repeat
             lend:=true;
             case TrStack[High(TrStack)] of
              '0': begin
                   if (Adress <> 0) then begin
                   // Занесение в польскую запись операции =
                   // и адреса засылки результата
                      SetLength(PZ,High(PZ)+3);
                      PZ[High(PZ)-1] := -7;
                      PZ[High(PZ)] := Adress;
                      Adress := 0;
                    end;
                   break;
                   end;
              '(': ErrorList.Add('Лишняя открытая скобка');
              else proc3;
             end;
            until lend;
            if (ErrorList.Count = 0)
             then Result:=true
             else Result:=false;
            if (SItem.mode = All) then exit
            else begin
             Assign := true;
             SItem.mode := None;
            end
           end;
   Divider:begin
           if((OldMode = Divider)and
             ((SItem.Ident[1]<>'=')and
             (SItem.Ident[1]<>'(')and
             (SItem.Ident[1] <> ')'))and
             ((OldS <> '(')and
             (OldS <> ')')and
             (OldS <> '=')))
            then begin
             ErrorList.Add('Позиция '+IntToStr(SItem.Pos1)+
                                      ': два подряд символа операции');
             break;
            end;
           repeat
            lend:=true;
            case SItem.Ident[1] of
             '=': if Assign and (OldMode = Ident)
                   then begin
                    // Запоминание адреса пересылки и
                    // удаление его из польской записи
                    Adress := PZ[High(PZ)];
                    SetLength(PZ,High(PZ));
                    SItem.mode := None;
                   end
                   else ErrorList.Add('Позиция '+IntToStr(SItem.Pos1)+
                                      ': символ "=" здесь недопустим');
             '(': if(OldMode = Ident) or (OldMode = Number)
                  then ErrorList.Add('Ошибочная скобка в позиции '+IntToStr(SItem.Pos1))
                  else  proc1;
             '+','-','M': begin
                  if((OldMode = None)or(OldS = '('))
                   // Унарная операция
                   then if (SItem.Ident[1] = '+') // Игнорируется
                    then break
                   // Унарный '-' - условный символ 'M'
                   else SItem.Ident[1] := 'M';
                  case TrStack[High(TrStack)] of
                   '0','(': proc1;
                   '+','-','M': proc2;
                   '*','/','^': proc3;
                  end;
                  end;
             '*','/':
                  if OldS = '('
                  then ErrorList.Add('Ошибочная операция в позиции '+IntToStr(SItem.Pos1))
                  else
                  case TrStack[High(TrStack)] of
                   '0','(','+','-','M': proc1;
                   '*','/': proc2;
                   '^': proc3;
                  end;
             '^':
                  if OldS = '('
                  then ErrorList.Add('Ошибочная операция в позиции '+IntToStr(SItem.Pos1))
                  else
                  case TrStack[High(TrStack)] of
                   '0','(','+','-','*','/','M': proc1;
                   '^': proc2;
                  end;
             ')':
                  case TrStack[High(TrStack)] of
                   '0': ErrorList.Add('Лишняя закрытая скобка');
                   '(': begin
                         proc4;
                         if (Ord(TrStack[High(TrStack)]) > 127)
                          then proc6;
                        end;
                   '+','-','*','/','^','M': proc3;
                  end;
            end;
           until lend;
           Assign:=false;
           end;
   Func:   begin
           repeat
            lend:=true;
            proc5
           until lend;
           Assign:=false;
           end;
   None:   ErrorList.Add('Непонятный символ в позиции '+IntToStr(SItem.Pos1));
  end;
  OldMode := SItem.mode;
  OldS := SItem.Ident[1];
  SyntItem(S);
 until false;
 if(ErrorList.Count = 0)
 then Result := true
 else Result := false;
end;

function Calculate(var R:real):boolean;
var Stack: array of real;
    i:integer;
begin
  for i:=0 to High(PZ) do begin
   if (i > 0) then
    if (PZ[i-1] = -7) and (i < High(PZ)) then Continue;
   if PZ[i] < -100
// функция
    then begin
     try
      case -PZ[i]-100 of
       1: Stack[High(Stack)]:=Exp(Stack[High(Stack)]);
       2: Stack[High(Stack)]:=Sin(Stack[High(Stack)]);
       3: Stack[High(Stack)]:=Cos(Stack[High(Stack)]);
       4: Stack[High(Stack)]:=Sqrt(Stack[High(Stack)]);
       5: Stack[High(Stack)]:=Abs(Stack[High(Stack)]);
       6: Stack[High(Stack)]:=Ln(Stack[High(Stack)]);
       7: Stack[High(Stack)]:=Tan(Stack[High(Stack)]);
       8: Stack[High(Stack)]:=ArcTan(Stack[High(Stack)]);
       9: Stack[High(Stack)]:=ArcCos(Stack[High(Stack)]);
      end
     except
      Result := false;
      exit;
     end;
     if(FloatToStr(Stack[High(Stack)]) = 'NAN') or
       (FloatToStr(Stack[High(Stack)]) = 'INF') or
       (FloatToStr(Stack[High(Stack)]) = '-INF')
      then begin
       Result := false;
       exit;
      end
    end
    else if PZ[i] < 0
// операция
    then begin
    try
     case -PZ[i] of
      1: Stack[High(Stack)-1]:=
         Stack[High(Stack)-1]+Stack[High(Stack)];
      2: Stack[High(Stack)-1]:=
         Stack[High(Stack)-1]-Stack[High(Stack)];
      3: Stack[High(Stack)-1]:=
         Stack[High(Stack)-1]*Stack[High(Stack)];
      4: Stack[High(Stack)-1]:=
           Stack[High(Stack)-1]/Stack[High(Stack)];
      5: Stack[High(Stack)-1]:=
           Power(Stack[High(Stack)-1],Stack[High(Stack)]);
      6: Stack[High(Stack)]:= -Stack[High(Stack)];
      7: DataList[PZ[i+1]-NConst].Data := Stack[High(Stack)];
     end;
    except
     Result := false;
     exit;
    end;
     if (PZ[i] <> -6)  // Не унарная операция
       then SetLength(Stack,High(Stack));
    end
    else begin
     SetLength(Stack,High(Stack)+2);
     if (PZ[i] < NConst)
      then Stack[High(Stack)]:=ConstList[PZ[i]]
      else Stack[High(Stack)]:=DataList[PZ[i]-NConst].Data;
    end;
 end;   
 Result := true;
 R :=Stack[High(Stack)];
end;

function SetData(Name:string; Data:real):boolean;
var i:integer;
begin
 for i:=MConst to High(DataList) do
  if (UpperCase(Name) = DataList[i].Name)
   then  begin
    DataList[i].Data := Data;
    Result:=true;
    exit;
   end;
 Result := false;
end;

function GetData(Name:string; var Data:real):boolean;
var i:integer;
begin
 for i:=0 to High(DataList) do
  if (UpperCase(Name) = DataList[i].Name)
   then  begin
    Data := DataList[i].Data;
    Result:=true;
    exit;
   end;
 Result := false;
end;

initialization
 SetLength(DataList,MConst);
 DataList[0].Name:='PI';
 DataList[0].Data:=Pi;
 DataList[1].Name:='E';
 DataList[1].Data:=2.71828183;
 ErrorList := TStringList.Create;
finalization
 ErrorList.Free;
end.
