unit Un_func;
interface
//uses Un_objects;
Const MaxStackDepth=32;

Type
	 ErrorMessageType = (erNoError,erInvalidSymbol,erUndeclaredVar,
                             erUndeclaredFunc,erExpectedSymbol,erExtraCharacters,
                             erInvalidNumber,erDivideByZero,erInvalidArgument);
	 PFunction = ^TFunction;
	 TFunction = record
					Name:String[8];
					Code:Pointer;{Указатель на процедуру}
					ParamCount:Integer;
				  end;
        PVariable = ^TVariable;
	TVariable = record
				  Name:String[8];
				  Code:LongInt;
				end;
	TCalcFunc=Procedure;{Тип процедуры, вычисляющей пользовательскую функцию}
	 {Эта процедура выполняет следующую последовательность действий:
	   1.Уменьшает значение глобальной переменной SP на число своих параметров-1
	   2. Проверяет значения аргументов и, если они плохие,
	      присваивает переменной ExecuteError значение erInvalidArgument,
	      на чем с честью и завершается
	   3. Вычисляет значение пользовательской функции, считая, что
		  первый параметр находится в Stack[SP], второй в Stack[SP+1] и т.д
	   4. Присваивает результат вычисления Stack[SP]}
        PLongInt = ^LongInt;
var     SP:1..MaxStackDepth;
	Stack:Array[1..MaxStackDepth] of Real;
	{Это стек интерпретатора. Он вынесен в интерфейс, так как им пользуются
	 процедуры, вычисляющие пользовательские функции}

	GetVariable:Function(Code:LongInt):Real;
	{Сюда помещается указатель на пользовательскую функцию, возвращающую
	 значение указанной переменной. По умолчанию - возвращает 0}
	CheckVariable:Function(VarName:String):LongInt;
	{Сюда помещается указатель на пользователькую функцию, возвращающую
	 0 если строка VarName не является корректным именем переменной,
	 иначе возвращающая код который следует передать в GetVariable для
	 получения значения этой переменной}
	ShowError:Procedure(Message:ErrorMessageType;Symbol:String;Position:Integer);
	{Эта процедура вызывается в случае возникновения ошибки при компиляции
	 По умолчанию  выводит в файл OUTPUT сообщение на русском языке
	Семантика параметров:
	   Message - тип ошибки
	   Symbol - символ (в т.ч идентификатор) на котором споткнулась компиляция
           Position - положение оного в строке.}
	CompileError:Boolean;{Устанавливается в True, если при компиляции
        	были ошибки. Какие - об этом было сообщено процедуре ShowError}
        ExecuteError:ErrorMessageType;{Содержит erNoError,если все OK
                                    иначе- код ошибки времени выполнения}

	Function CompileExpression(Expr:String):String;
	{Компилирует выражение во внутненний постфиксный формат}

	Function InterpreteExpression(Code:String):Real;
	{Интерпретирует  выражение во внутреннем формате и возвращает его значение}

	Procedure AddStdFunctions;{Очищает таблицу функций и
                                  заносит туда стандартные функции (см. ниже)}

	Procedure ClearVars;{Oчищает таблицу переменных}

	Procedure AddFunction(Name:String;ParamCount:Integer;
			  Code:TCalcFunc);
         {Добавляет в таблицу функций функцию пользователя с именем Name
         (должно быть в верхнем регистре), количеством параметорв ParamCount,
          Вычисляемую процедурой Code (см. описание типа TCalcFunc)}

	Procedure AddVariable(Name:String;Code:Integer);
        {Добавляет в таблицу переменных переменную с именем Name(должно быть
         в верхнем регистре) и кодом Code. Code это то, что будет передано
         в функцию GetVariable, когда в выражении встретится переменная
         с данным именем. Если Вы решили воспользоваться данным механизмом,
         позаботьтесь о реализации функции GetVariable, поскольку версия
         по умолчанию Вас вряд ли устроит}

{Стандартные функции}
Procedure CalcLn;{Ln(X)- натуральный логарифм}
Procedure CalcLg;{Lg(X)- десятичный логарифм}
Procedure CalcExp;{exp(X) - e в степени x}
Procedure CalcPwr10;{pwr10(X) - 10 в степени x}
Procedure CalcAbs;{Abs(X) - абсолютная величина x}
Procedure CalcSqr;{Sqr(X) - квадрат x}
Procedure CalcSqrt;{Sqrt(X) - корень из x}
Procedure CalcSin;{sin(X)}
Procedure CalcCos;{cos(X)}
Procedure CalcTg;{tg(X)}
Procedure CalcArcTg;{arctg(X)}
Procedure CalcArcSin;{arcsin(X)}
Procedure CalcArcCos;{arccos(X)}
Procedure CalcPower;{Power(X,Y) - x в степени y}
Procedure CalcRoot;{Root(X,Y) - корень степени y из x}
Procedure CalcLog;{Log(X,Y) - логарифм x по основанию y}

implementation
Const {Коды операции}
	  opConst = 0;{Следующие 6 байт - константа, которую следует занести в стек}
	  opVariable   = 1;{Следующие 4 байта - номер переменной}
	  opFunction  =2;{следующие 4 байта - указатель на процедуру, которую
					  следует вызвать для вычисления функции}
	  opPlus = ord('+');
	  opMinus = ord ('-');
	  opMult = ord ('*');
	  opRDiv = ord ('/');
	  {Кстати! для того чтобы генерировать настоящий исполняемый код для
	   сопроцессора надо всего лишь изменить значения констант и использовать
	   Double вместо Real}
	  Ln10 = 2.302585092994;

var   FuncTable, VarTable : PSortedCollection;
Type    PCompTable = ^TCompTable;
        TCompTable = object (TStringCollection)
                       ElSize:Integer;
                       Constructor Init(Alimit,ADelta,AElSize:Integer);
                       Procedure FreeItem(Item:Pointer);virtual;
                     end;
Constructor TCompTable.Init(Alimit,ADelta,AElSize:Integer);
begin
 TStringCollection.Init(Alimit,ADelta);
 ElSize:=AElSize;
end;
Procedure TCompTable.FreeItem(Item:Pointer);
begin
 If Item<>nil then FreeMem(Item,ElSize);
end;

{$F+}
Procedure StdError(Message:ErrorMessageType;Symbol:String;ErrorPoint:Integer);
{$F-}
begin

 Writeln;
 Writeln('^':ErrorPoint);
 Case Message of
 erInvalidSymbol:Writeln('Недопустимый символ:''',Symbol,'''');
 erUndeclaredVar:Writeln('Неизвестная переменная:',Symbol);
 erUndeclaredFunc:Writeln('Неизвестная функция:',Symbol);
 erExpectedSymbol:Writeln('Ожидался символ:',Symbol);
 erExtraCharacters:Writeln('Лишние символы в строке');
 erInvalidNumber:Writeln('Неправильное число');
 end;
end;
{$F+}
Function StdGetVariable(Code:LongInt):Real;
begin
 StdGetVariable:=0;
end;

Function StdCheckVariable(VarName:String):LongInt;
var I:Integer;
begin
   if VarTable^.Search(@VarName,i) then
    StdCheckVariable:=PVariable(VarTable^.At(i))^.Code
   else StdCheckVariable:=0;
end;

{$F-}
Function CompileExpression(Expr:String):String;
Type TLexema=String;
var Lexema:TLexema;{Текущая лексема}
	IsNumber,isIdentifier,isFunction:Boolean;{Тип лексемы}
	Parameters:Integer;
	ParsePtr:Integer;
	Code:String;
Const ConstValue:String[1+SizeOf(REal)]=chr(opConst)+'      ';
Procedure Error(Message:ErrorMessageType;Symbol:String);
begin
 CompileError:=True;
 ShowError(Message,Symbol,ParsePtr);
end;
  Function IsDeclared(Lexema:TLexema;var Code:String):Boolean;
  var i:LongInt;
  begin
   i:=CheckVariable(Lexema);
   if i<>0 then
    begin
     IsDeclared:=True;
     Code[0]:=#5;
     Code[1]:=chr(OpVariable);
     Move(i,Code[2],SizeOf(LongInt))
    end else IsDeclared:=False;
  end;
Procedure GetLexema;
var i:Integer;
	R:Real;
begin
  isFunction:=False;
  if CompileError then exit;
  if ParsePtr>Length(expr) then begin Lexema:=#13;Exit end;
  Lexema:=Expr[ParsePtr];
  Case Lexema[1] of
  '0'..'9':
			begin
				 i:=1;
			 Repeat
			  inc(i);
			   Lexema[i]:=Expr[ParsePtr+Pred(i)]
			 Until not (Lexema[i] in ['0'..'9','.']);
			 Inc(ParsePtr,Pred(i));
			 Lexema[0]:=Chr(Pred(i));
			 Val(Lexema,R,i);
			 if I<>0 then Error(erInvalidNumber,Lexema);
			 Move(R,ConstValue[2],SizeOf(Real));
			 isNumber:=True;
			 isIdentifier:=False;
			end;
   'A'..'Z','a'..'z':
			begin
			 i:=1;
			 Repeat
			  Lexema[i]:=Upcase(Lexema[i]);
			  inc(i);
			  Lexema[i]:=Expr[ParsePtr+Pred(i)];
			 Until not(Lexema[i] in ['A'..'Z','a'..'z','0'..'9','_']);
			 Lexema[0]:=Pred(chr(i));
			 Inc(ParsePtr,Pred(i));
			 if (ParsePtr<=Length(Expr))and(Expr[ParsePtr]='(') then
			 isFunction:=True;
			 isNumber:=False;
			 isIdentifier:=True;
			end;
   #13,#10,'+','-','*','/','(',')','[',']',',':
			begin
			 isNumber:=False;
			 isIdentifier:=False;
			 inc(ParsePtr);
			end;
   else
			Error(erInvalidSymbol,Lexema);
   end;
  While (ParsePtr<=Length(Expr))and(Expr[ParsePtr] in [' ',#9]) do
   inc(ParsePtr);
end;
Procedure GenerateCode(CodePart:String);
begin
 Code:=Code+CodePart;

end;
Procedure Expression;
var Op:TLexema;
	Procedure Funct;
	var i,j:Integer;
		MyCode:String[5];
             Params:Integer;
	begin
   if FuncTable^.Search(@Lexema,i) then
	  begin
	   MyCode[0]:=#5;
	   MyCode[1]:=chr(opFunction);
           With PFunction(FuncTable^.At(i))^ do
            Begin
             Move(Code,MyCode[2],SizeOf(Pointer));
             Params:=ParamCount;
            end;
	   GetLexema;
	   if Lexema<>'(' then begin Error(erExpectedSymbol,'(');exit end;
	   GetLexema;
	   Expression;
	   j:=2;
	   While j<=Params do
		begin
		 if Lexema<>',' then begin Error(erExpectedSymbol,','); exit end;
		 GetLexema;
		 Expression;
		 inc(j);
		end;
		if Lexema<>')' then begin Error(erExpectedSymbol,')');exit end;
	   GenerateCode(MyCodE);
	  end Else Error(erUndeclaredFunc,Lexema);

	end;
	Procedure Term;
	var Op:TLexema;
      Procedure Factor;
	  var FuncCode:String;
	   begin
		if CompileError then Exit;
		if Lexema='(' then
		 begin{Выражение в скобках}
		  GetLexema;
		  Expression;
		  if Lexema<>')' then
		   Error(ErExpectedSymbol,')');
		 end
		else
		   if IsIdentifier then
			if IsFunction then
			 Funct
			else
			 begin
			  if isDeclared(Lexema,FuncCode) then
				GenerateCode(FuncCode)
			  else
			   Error(erUndeclaredVar,Lexema);
			 end
		  else
		   GenerateCode(ConstValue);{Переменная или константа}
		GetLexema;
	   end;{Factor}
	begin {Term}
	 if CompileError then exit;
	 Factor;
	  While ((Lexema='*')or(Lexema='/'))and not CompileError do
	   begin
		Op:=Lexema;
		GetLexema;
		Factor;
		GenerateCode(Op);
	  end;
   end;{Term}

begin {Expression}
 if CompileError then exit;
 Term;
 While ((Lexema='+') or (Lexema='-'))and not CompileError do
  begin
	Op:=Lexema;
	GetLexema;
	Term;
	generateCode(Op);
  end;
end;{Expression}

begin
  CompileError:=False;
  Code:='';
  Expr:=Expr+' ';
  ParsePtr:=1;
  GetLexema;
  Expression;
  if Lexema<>#13 then Error(erExtraCharacters,'');
  CompileExpression:=Code;
end;
Function InterpreteExpression(Code:String):Real;
Type PReal=^Real;
	 PPointer=^Pointer;
	 PInteger=^Integer;
var IP:Integer;CurCode:Byte;
	WorkFunction:TCalcFunc;
begin
 SP:=1;
 ip:=1;
 While ip<=Length(Code) do
  begin
   CurCode:=Ord(Code[ip]);
   inc(IP);
   case CurCode of
   opConst:begin
			 inc(SP);
			 Stack[SP]:=PReal(@Code[IP])^;
			 inc(IP,SizeOf(Real));
		   end;
  opVariable:begin
			  inc(SP);
			  Stack[SP]:=GetVariable(PLongInt(@Code[IP])^);
			  inc(IP,SizeOf(LongInt));
			 end;
  opFunction:begin
			   @WorkFunction:=PPointer(@Code[ip])^;
			   inc(IP,SizeOf(Pointer));
			   WorkFunction;
                           if ExecuteError<>erNoError then exit;
			  end;
  opPlus:Begin
			Dec(SP);
			Stack[SP]:=Stack[SP]+Stack[SP+1];
		 end;
  opMinus:Begin
			Dec(SP);
			Stack[SP]:=Stack[SP]-Stack[SP+1];
		 end;
  opMult:Begin
			Dec(SP);
			Stack[SP]:=Stack[SP]*Stack[SP+1];
		 end;
  opRDiv:Begin
                        if Stack[SP]=0.0 then begin ExecuteError:=erDivideByZero;exit;end;
			Dec(SP);
			Stack[SP]:=Stack[SP]/Stack[SP+1];
		 end;
  end;
 end;
 InterpreteExpression:=Stack[SP];
end;
Procedure ClearVars;
begin
 VarTable^.FreeAll;
end;
Procedure AddFunction(Name:String;ParamCount:Integer;Code:TCalcFunc);
var P:^TFunction;
begin
 New(P);
 P^.Name:=Name;
 P^.Code:=@Code;
 P^.ParamCount:=ParamCount;
 FuncTable^.Insert(P);
end;
Procedure AddVariable(Name:String;Code:Integer);
var P:^TVariable;
begin
 New(P);
 P^.Name:=Name;
 P^.Code:=Code;
 VarTable^.Insert(P);
end;
Procedure AddStdFunctions;
begin
 FuncTable^.FreeAll;
 AddFunction('LN',1,CalcLn);
 AddFunction('LG',1,CalcLg);
 AddFunction('EXP',1,CalcExp);
 AddFunction('PWR10',1,CalcPwr10);
 AddFunction('ABS',1,CalcAbs);
 AddFunction('SQR',1,CalcSqr);
 AddFunction('SQRT',1,CalcSqrt);
 AddFunction('SIN',1,CalcSin);
 AddFunction('COS',1,CalcCos);
 AddFunction('TG',1,CalcTg);
 AddFunction('ARCTG',1,CalcArcTg);
 AddFunction('ARCSIN',1,CalcArcSin);
 AddFunction('ARCCOS',1,CalcArcCos);
 AddFunction('POWER',2,CalcPower);
 AddFunction('ROOT',2,CalcRoot);
 AddFunction('LOG',2,CalcLog);
end;
{$F+}
Procedure CalcLn;
begin
 if Stack[SP]<=0 then begin ExecuteError:=erInvalidArgument;exit end;
 Stack[Sp]:=Ln(Stack[Sp]);
end;
Procedure CalcLg;
begin
 if Stack[SP]<=0 then begin ExecuteError:=erInvalidArgument;exit end;
 Stack[SP]:=Ln(Stack[SP])/Ln10;
end;
Procedure CalcExp;
begin
 Stack[SP]:=Exp(Stack[SP]);
end;
Procedure CalcPwr10;
begin
 Stack[SP]:=Exp(Stack[SP]*Ln10);
end;
Procedure CalcAbs;
begin
 Stack[SP]:=Abs(Stack[SP]);
end;
Procedure CalcSqr;
begin
 Stack[SP]:=Sqr(Stack[SP]);
end;
Procedure CalcSqrt;
begin
 if Stack[SP]<0 then begin ExecuteError:=erInvalidArgument;exit end;
 Stack[SP]:=Sqrt(Stack[SP]);
end;
Procedure CalcSin;
begin
 Stack[SP]:=Sin(Stack[SP]);
end;
Procedure CalcCos;
begin
 Stack[SP]:=Cos(Stack[SP]);
end;
Procedure CalcTg;
var R:Real;
begin
 R:=Cos(Stack[SP]);
 if R=0 then Begin ExecuteError:=erInvalidArgument;exit end;
 Stack[Sp]:=Sin(Stack[SP])/R;
end;
Procedure CalcArcTg;
begin
 Stack[SP]:=ArcTan(Stack[SP]);
end;
Procedure CalcArcSin;
begin
 Stack[SP]:=ArcTan(Stack[SP]/Sqrt(1-Sqr(Stack[SP])));
end;
Procedure CalcArcCos;
begin
 if Abs(Stack[SP])>1 then begin ExecuteError:=erInvalidArgument;exit end;
 Stack[SP]:=arctan(Sqrt(1-Sqr(Stack[SP]))/Stack[SP]);
end;

{Two-argument functions}
Procedure CalcPower;
begin
 Dec(SP);
 if Stack[SP]<=0 then begin ExecuteError:=erInvalidArgument;exit end;
 Stack[SP]:=Exp(Ln(Stack[SP])*Stack[SP+1]);
end;
Procedure CalcRoot;
begin
 Dec(SP);
 Stack[SP]:=Exp(Ln(Stack[SP])/Stack[SP+1]);
end;
Procedure CalcLog;
begin
 if Stack[SP]<=0 then begin ExecuteError:=erInvalidArgument;exit end;
 Dec(SP);
 if Stack[SP]<=0 then begin ExecuteError:=erInvalidArgument;exit end;
 Stack[SP]:=Ln(Stack[SP])/Ln(Stack[SP+1]);
end;
{$F-}
begin
 ClearVars;
 AddStdFunctions;
 GetVariable:=StdGetVariable	;
 CheckVariable:=StdCheckVariable;
 ShowError:=StdError;
end.

