unit FEvalLib;
{*******************************************************
 * knihovna pro syntaktickou kontolu a vypocet vyrazu  *
 * s jednou nebo zadnou promennou za behu programu     *
 *                                                     *
 * Vytvoril: Adam Husar, xhusar01@stud.fit.vutbr.cz    *
 * Datum posledni upravy: 9. 4. 2003                   *
 * (vypocet predelan na vypoc. pomoci postfixu)        *
 *******************************************************}

{*************************************************************

Verejne funkce tridy TFunctionEval:

    constructor Create;
    destructor  Close;
    function    ReadExpr(strExpr: string): integer;
    function    EvalExpr(Variable: extended): extended;
    function    GetLoadedExpr: string;

************************************************************}


interface


const
  MAX_BUFFER_SIZE = 65535; //maximalni velikost pameti pro buffer


////definice funkci a operatoru (hodnoty v bufferu)
  I_NOTHING = 0;
  I_VAR     = 1;

 //operatory (podle priority)
 IS_OPER_FIRST = 2;
  I_POWER   = 2;
  I_DIV     = 3;
  I_MUL     = 4;
  I_MINUS   = 5;
  I_PLUS    = 6;
 IS_OPER_LAST = 6;

 //konstanty
  I_PI      = 7;
  I_E       = 8;

 //funkce
 IS_FUNC_FIRST = 10;
  I_SIN     =10;
  I_COS     =11;
  I_TAN     =12;
  I_COT     =13;
  I_ARCSIN  =14;
  I_ARCCOS  =15;
  I_ARCTAN  =16;
  I_ARCCOT  =17;
  I_SINH    =18;
  I_COSH    =19;
  I_TANH    =20;
  I_COTH    =21;
  I_ARCSINH =22;
  I_ARCCOSH =23;
  I_ARCTANH =24;
  I_ARCCOTH =25;

  I_LN      =27;
  I_SGN     =28;
  I_INT     =29;
  I_ROUND   =30;
  I_ABS     =31;
  I_FACT    =32;
 IS_FUNC_LAST = 32;

// !! nazev funkce nesmi obsahovat prvni pismeno promenne
// !! nebo konstanty, misto exp(x) pouzivat e^x

 //ostatni
  I_LBRACKET =50;
  I_RBRACKET =51;
  I_DOT      =52;

  BUFFER_SIZE = 256; //pocet policek v bufferu


//typy znaku v retezci (pouzivane pri rozdelovani retezce)
  E_NOTHING  = 0;
  E_NUMBER   = 1;
  E_VAR      = 2;
  E_BINOP    = 3;
  E_MINUS    = 4;
  E_FUNCTION = 5;
  E_LBRACKET = 6;
  E_RBRACKET = 7;

// pomocne pole pro zjistovani nazvu funkci
type
  TFunctions = array[I_SIN .. I_FACT] of string[10];
const
  FUNCTIONS: TFunctions = ( 'SIN', 'COS', 'TAN', 'COT', 'ARCSIN', 'ARCCOS',
                            'ARCTAN', 'ARCCOT', 'SINH', 'COSH', 'TANH', 'COTH',
                            'ARCSINH', 'ARCCOSH', 'ARCTANH', 'ARCCOTH',
                            'MOD', 'LN',  'SGN', 'INT', 'ROUND', 'ABS',
                            'FACT');


type
  ShortStr= string[50];

  TItem = record
    Value: extended; //hodnota bud cisla nebo jedne z konstant (fce,operator,..)
    IsNumber: boolean;
  end;

  TBufferAr = array[1..MAX_BUFFER_SIZE] of TItem;
  TpBufferAr = ^TBufferAr;

 //trida obsluhujici buffer
  TBuffer = class
    public
      constructor Create(MaxSize: integer);
      destructor  Close;

      procedure   NewBuf;
      procedure   AddValue(Item: TItem);
      function    GetValue(ItemNum: integer): TItem;
      procedure   SetValue(ItemNum: integer; Item:TItem);
      function    GetSize: integer;
      procedure   SetSize(nSize: integer);

      function    FindFirst(What: integer): integer;
      function    FindNext(What: integer): integer;

      procedure   DeleteItems(From, Count: integer);
    protected

    private
      pBuffer, pTempBuffer: TpBufferAr;
      Size, AllocatedSize: integer;
      LastFound: integer;
  end;

 ///********  zasobnik
  pTStItem = ^TStItem;
  TStItem = record
    It: TItem;
    pLower: pTStItem;
  end;

  TStack = class       //zasobnik TItem
    public
      constructor Create;
      destructor  Close;

      procedure   Push(It: TItem);
      function    Top: TItem;
      function    TopPop: TItem;
      function    IsEmpty: boolean;

    private
      pTop: pTStItem;
  end;
 ///********  zasobnik


 // pomocna trida pro vyhodnocovani cisel
  TExprNumber = class
    public
      constructor Create;
      destructor  Close;

      procedure AddNum(Digit: char);
      procedure NewNum(Digit: char);
      function  GetValue(var Value: extended): integer; //vraci chybovy kod
    private
      strNumber: ShortStr;
      posNumber: integer;
  end;

 // pomocna trida pro vyhodnocovani funkci
  TExprFunction = class
    public
      constructor Create;
      destructor  Close;

      procedure AddFunc(FuncChar: char);
      procedure NewFunc(FuncChar: char);
      function  GetFunc(var FuncNum: integer): integer; //vraci chybovy kod
    private
      strFunc: ShortStr;
      posFunc: integer;
  end;


// ********************************************************************
//********************* deklarace tridy TFunctionEval  *****************
// ********************************************************************
type
  TFunctionEval = class
    public
      constructor Create;
      destructor  Close;
      function    ReadExpr(strExpr: string): integer;
      function    EvalExpr(Variable: extended): extended;
      function    GetLoadedExpr: string;

    private
      procedure   RemoveUnaryPluses(var strExpr: string);
      function    CheckBracketsCount(Buf: TBuffer): boolean;
        //fce zkontroluje zda si zavorky v bufferu odpovidaji
        //(stejny pocet levych a pravych,...)

      procedure   AsignVariable(Buf: TBuffer; Which:integer; Variable: extended);

      function    SpecPower(x, n: extended): extended;
      function    Factorial(Base: integer): extended;

      procedure InfixToPostFix(var Buf: TBuffer);
      function  PostfixEval(Buf: TBuffer): extended;


      function   CountBinOp(Which: integer; r1, r2: extended): extended;
      function   CountFunc(Which: integer; Value: extended):extended;
    private
      ExprBuf, EvalBuf, CountBuf: TBuffer; //ExprBuf-buffer pro ulozeni vyrazu po ReadExpr
                  //fce EvalExpr si kopiruje jeho hodnotu do EvalBuf pro vypocet
      LoadedExpr: string;

      bPostFixConv: boolean;
  end;
// ********************************************************************
//********************* deklarace tridy TFunctionEval  *****************
// ********************************************************************




//***********************************************************************
implementation



uses
  SysUtils, Math,
  Forms, Errors;

//funkce pro pouziti uvnitr knihovny

function  GetBinOpNumber(BinOp: char): integer; forward;
function  ValueToItem(Value: extended; IsNumber: boolean): TItem; forward;
procedure CopyActiveBuffer(var TargBuf: TBuffer; const SourBuf: TBuffer); forward;


/// ^^***********************  TFunctionEval *******************************^^



function TFunctionEval.CountFunc(Which: integer; Value: extended):extended;
//podm pro vypocet fce: v bufferu za sebou nasleduji fce a cislo
//vraci true pokud se buffer zmenil (nejaka fce byla vypocitana)
var
  extResult: extended;
begin
  try

    extResult:= 0;

      case Which of
          I_SIN  :
            extResult:= Sin(Value);
          I_COS  :
            extResult:= Cos(Value);
          I_TAN  :
            if Value / pi + 0.5 <> trunc( Value / Pi + 0.5) then
              extResult:= Tan(Value)
            else
              SetLastErrorCode(ERR_TAN_FVAL_UNDEF);
          I_COT  :
            if Value / pi  <> trunc( Value / Pi) then
              extResult:= Cot(Value)
            else
              SetLastErrorCode(ERR_COT_FVAL_UNDEF);
          I_ARCSIN:
            if (Value <=1) and (Value >= -1) then
              extResult:= ArcSin(Value)
            else
              SetLastErrorCode( ERR_ARCSIN_FVAL_UNDEF);
          I_ARCCOS:
            if (Value <=1) and (Value >= -1) then
              extResult:= ArcCos(Value)
            else
              SetLastErrorCode( ERR_ARCCOS_FVAL_UNDEF);
          I_ARCTAN:
            extResult:= ArcTan(Value);
          I_ARCCOT:
            extResult:= ArcCot(Value);

          I_SINH:
            extResult:= Sinh(Value);
          I_COSH:
            extResult:= Cosh(Value);
          I_TANH:
            extResult:= Tanh(Value);
          I_COTH:
            if Value <> 0 then
              extResult:= Coth(Value)
            else
              SetLastErrorCode( ERR_COTH_FVAL_UNDEF);
          I_ARCSINH:
            extResult:= ArcSinh(Value);
          I_ARCCOSH:
            if Value >= 1 then
              extResult:= ArcCosh(Value)
            else
              SetLastErrorCode( ERR_ARCCOSH_FVAL_UNDEF);
          I_ARCTANH:
            if (Value > -1) and (Value < 1) then
              extResult:= ArcTanh(Value)
            else
              SetLastErrorCode( ERR_ARCTANH_FVAL_UNDEF);
          I_ARCCOTH:
            if (Abs(Value) > 1) then
              extResult:= ArcCotH(Value)
            else
              SetLastErrorCode( ERR_ARCCOTH_FVAL_UNDEF);
          I_LN :
            if Value >0 then
              extResult:= Ln(Value)
            else
              SetLastErrorCode( ERR_LN_FVAL_UNDEF);
          I_SGN:
            extResult:= Sign(Value);
          I_INT:
            extResult:= Trunc(Value);
          I_ROUND:
            extResult:= Round(Value);
          I_ABS:
            extResult:= Abs(Value);
          I_FACT:
            if (Value >= 0) and (Value = Trunc(Value)) then
              extResult:= Factorial(Trunc(Value))
            else
              SetLastErrorCode( ERR_FACT_FVAL_UNDEF);
        end; //konec case


  except
    on EOverFlow do begin
      SetLastErrorCode( ERR_OVERFLOW);
      extResult:= 0;
    end;
  end;

  CountFunc:= extResult;
end; //konec CountFunc


function TFunctionEval.SpecPower(x, n: extended): extended;
//vyvolava funkci power ale pred tim kontroluje zda
//zaklad neni zaporny a zaroven exponent je "necele" cislo
begin
  if (x < 0) and (n <> trunc(n)) then begin
    SetLastErrorCode( ERR_ILL_POWER);
    SpecPower:= 0;
  end
  else
    SpecPower:= Power(x,n);
end;


function TFunctionEval.Factorial(Base: integer): extended;
var
  extResult: extended;
  i: integer;
begin
  extResult:= 1;

  for i:= 2 to Base do
    extResult:= extResult * i;

  Factorial:= extResult;
end;


function TFunctionEval.CountBinOp(Which: integer; r1, r2: extended): extended;
//spocita vysledek podle r1 (which) r2 a ten vraci
var
  extResult: extended;
begin
  extResult:=0;

   case Which of
      I_POWER:
        extResult:= SpecPower(r1, r2);
      I_DIV:
        if r2 <> 0 then
          extResult:= r1/r2
        else
          SetLastErrorCode( ERR_ZERO_DIV);
      I_MUL:
        extResult:= r1 * r2;
      I_MINUS:
        extResult:= r1 - r2;
      I_PLUS:
        extResult:= r1 + r2;
  end;

  CountBinOp:= extResult;
end;  ///////// *********  konec fce  CountBinOp *************


procedure TFunctionEval.AsignVariable(Buf: TBuffer; Which: integer;
  Variable: extended);
//proc dosadi do bufferu za 'x' hodnotu promenne
var
  sizeBuf, i: integer;
  Item: TItem;
begin
  sizeBuf:= Buf.GetSize;
  for i:= 1 to sizeBuf do
    begin
      Item:=Buf.GetValue(i);
      if (Item.IsNumber = FALSE) and (Item.Value = Which) then
        Buf.SetValue(i, ValueToItem(Variable, true));
    end;
end;



procedure TFunctionEval.InfixToPostFix(var Buf: TBuffer);
var
  outBuf: TBuffer;
  St: TStack;
  i, val: integer;
  auxIt, auxIt2: TItem;
begin
  outBuf:= TBuffer.Create(BUFFER_SIZE);
  St:= TStack.Create;

  for i:= 1 to Buf.GetSize do begin
    auxIt:= Buf.GetValue(i);
    val:= trunc(auxIt.Value);  //pomocna promenna pro uchovani hodnoty

    if auxIt.IsNumber or (trunc(auxIt.Value) = I_VAR) then
      outBuf.AddValue(auxIt)

    else begin
      if (val >= IS_OPER_FIRST) and (val <= IS_OPER_LAST) then begin //operator

        while not ( St.IsEmpty or (trunc(St.Top.Value) = I_LBRACKET)
            or (not((trunc(St.Top.Value)>=IS_FUNC_FIRST)
                       and (trunc(St.Top.Value) <= IS_FUNC_LAST))
                   and (val = I_POWER) )  // ^ a na vrchu neni funkce
            or ((val in [I_MUL, I_DIV]) and ( (trunc(St.Top.Value) = I_PLUS)
                   or (trunc(St.Top.Value) = I_MINUS) ))) do  // *,/ a na vrchu je +, -

          outBuf.AddValue(St.TopPop);

        St.Push(auxIt);
      end

      else if ((val >= IS_FUNC_FIRST) and (val <= IS_FUNC_LAST)) //funkce, ( ?
          or (val = I_LBRACKET) then
        St.Push(auxIt)
      else if (val = I_RBRACKET) then begin  // )
        auxIt2:= St.TopPop;
        while (trunc(auxIt2.Value) <> I_LBRACKET) do begin
          outBuf.AddValue(auxIt2);
          auxIt2:= St.TopPop;
        end;
      end;

    end; {else}

  end; {for}

  while not St.IsEmpty do  //vyprazdneni zasobniku
    outBuf.AddValue(St.TopPop);


  CopyActiveBuffer(Buf, outBuf);
  outBuf.Close;
  St.Close;

  bPostFixConv:= true;
end;


function TFunctionEval.PostfixEval(Buf: TBuffer): extended;
var
  i: integer;
  auxIt, auxIt2, auxIt3: TItem;
  St: TStack;
begin
  St:= TStack.Create;

  for i:= 1 to Buf.GetSize do begin
    auxIt:= Buf.GetValue(i);

    if auxIt.IsNumber then
      St.Push(auxIt)
    else begin
      auxIt2:= St.TopPop;

      if (trunc(auxIt.Value) >= IS_FUNC_FIRST)   //vypocist funkci?
           and (trunc(auxIt.Value) <= IS_FUNC_LAST) then
        St.Push(ValueToItem(
          CountFunc(trunc(auxIt.Value), auxIt2.Value), true))
      else begin
        auxIt3:= St.TopPop;

        St.Push(valueToItem(
          CountBinOp(trunc(auxIt.Value), auxIt3.Value, auxIt2.Value), true));
      end;
    end;
  end; {for}

  PostfixEval:= St.TopPop.Value;

  St.Close;
end;



function TFunctionEval.EvalExpr(Variable: extended): extended;
var
//  EvalBuf: TBuffer; //buffer pouzivany pro pocitani
//  bChanged: boolean;
  extRes: extended;
begin
 if not (LoadedExpr = '') then begin

  SetLastErrorCode( ERR_OK);



  if not bPostFixConv then  begin
    EvalBuf.NewBuf;
    CopyActiveBuffer(EvalBuf, ExprBuf);

   //dosazeni konstant
    AsignVariable(EvalBuf, I_PI, Pi);
    AsignVariable(EvalBuf, I_E, Exp(1));
   //konverze na infix
    InfixToPostfix(EvalBuf);
  end;

  CopyActiveBuffer(CountBuf, EvalBuf);
   //dosazeni promenne
  AsignVariable(CountBuf, I_VAR, Variable);

  extRes:= PostfixEval(CountBuf);

  if GetLastErrorCode = ERR_OK then  //vyhodnoceni vysledku
    EvalExpr:= extRes  //v poradku
  else
    EvalExpr:= 0;

 end  {begin za 1. if }
 else begin
   SetLastErrorCode( ERR_EXPR_NOT_LOADED);
   EvalExpr:= 0;
 end;
end;  // ************** konec fce EvalExpr ******************



procedure TFunctionEval.RemoveUnaryPluses(var strExpr: string);
//odstrani prebytecne plusy (napr.: +5-2.., (+x.. )
var
  posExpr, i: integer;
begin
  if length(strExpr) > 0 then begin
    if strExpr[1] = '+' then
      posExpr:= 1
    else
      posExpr:= pos('(+', strExpr);

    while posExpr > 0 do begin
      for i:= posExpr to Length(strExpr) - 1 do
        strExpr[i]:= strExpr[i+1];

      SetLength(strExpr, Length(strExpr) -1);
      posExpr:= pos('(+', strExpr);
    end;
  end;
end;


function TFunctionEval.CheckBracketsCount(Buf: TBuffer): boolean;
//fce kontroluje zda si vsechny zavorky odpovidaji
var
  BCount: integer;
  posBuf: integer;
  pomItem: TItem;
begin
  BCount:= 0;
  posBuf:=1;

  while (posBuf <= Buf.GetSize) and (BCount>=0) do begin
    pomItem:=Buf.GetValue(posBuf);
    if (not pomItem.IsNumber) then begin

      if (pomItem.Value = I_LBRACKET) then
        inc(BCount);
      if (pomItem.Value = I_RBRACKET) then
        dec(BCount);
    end;
    inc(posBuf);
  end;

  CheckBracketsCount:= (BCount = 0);
end;



function TFunctionEval.ReadExpr(strExpr: string): integer;
//funkce precte zadany retezec a pozadovanem tvaru ho ulozi do bufferu
//vraci pozici na ktere je chyba, pokud je vse v poradku vraci 0
var
  LastCharType, posExpr: integer;
  Num: TExprNumber;
  Func: TExprFunction;
  numResult: extended;
  funcResult: integer;
begin
  bPostFixConv:= false;
  LoadedExpr:='';

  Num:= TExprNumber.Create;
  Func:= TExprFunction.Create;

  ExprBuf.NewBuf; // pouze vymazani predchoziho obsahu

  RemoveUnaryPluses(strExpr);
  strExpr:= StrUpper(PChar(strExpr));

  LastCharType:=E_NOTHING;
  SetLastErrorCode( ERR_OK);

  posExpr:=1;
  while posExpr <= length(strExpr) do begin
    case strExpr[posExpr] of
      ' ': // mezera
        ;
      '0'..'9', '.', ',': //cislice nebo desetinna tecka
        if (strExpr[posExpr] in ['.', ','])
          and (strExpr[posExpr] <> DecimalSeparator) then
          SetLastErrorCode( ERR_ILL_DEC_SEPAR)
        else
        begin
          case LastCharType of
            E_NUMBER:
              Num.AddNum(strExpr[posExpr]);
            E_BINOP, E_LBRACKET, E_MINUS, E_NOTHING:
              Num.NewNum(strExpr[posExpr]);
            E_RBRACKET:
              begin
                Num.NewNum(strExpr[posExpr]);
                ExprBuf.AddValue(ValueToItem(I_MUL, false));
              end;
            E_FUNCTION, E_VAR:
              SetLastErrorCode( ERR_ILL_NUMBER);
          end;
          LastCharType:= E_NUMBER;
        end;

      '^', '*', '/', '+': //binarni operator
        begin
          case LastCharType of
            E_NUMBER:
              begin
                SetLastErrorCode( Num.GetValue(numResult));
                if GetLastErrorCode = ERR_OK then begin
                  ExprBuf.AddValue(ValueToItem(numResult, true));
                  ExprBuf.AddValue(
                    ValueToItem(GetBinOpNumber(strExpr[posExpr]), false));
                end;
              end;
            E_VAR, E_RBRACKET:
               ExprBuf.AddValue(
                 ValueToItem(GetBinOpNumber(strExpr[posExpr]), false));
            E_NOTHING, E_BINOP, E_MINUS, E_LBRACKET, E_FUNCTION:
              SetLastErrorCode( ERR_ILL_BINOP);
          end;
          LastCharType:= E_BINOP;
        end;

      '(':      // leva zavorka
        begin
          case LastCharType of
            E_NUMBER:
              begin
                SetLastErrorCode( Num.GetValue(numResult));
                if GetLastErrorCode = ERR_OK then begin
                  ExprBuf.AddValue(ValueToItem(numResult, true));
                  ExprBuf.AddValue(ValueToItem(I_MUL, false));
                  ExprBuf.AddValue(ValueToItem(I_LBRACKET, false));
                end;
              end;
            E_NOTHING, E_BINOP, E_MINUS, E_LBRACKET:
              ExprBuf.AddValue(ValueToItem(I_LBRACKET, false));
            E_FUNCTION:
              begin
                SetLastErrorCode( Func.GetFunc(funcResult));
                if GetLastErrorCode = ERR_OK then
                  begin
                    ExprBuf.AddValue(ValueToItem(funcResult, false));
                    ExprBuf.AddValue(ValueToItem(I_LBRACKET, false));
                  end;
              end;
            E_RBRACKET, E_VAR:
              begin
                ExprBuf.AddValue(ValueToItem(I_MUL, false));
                ExprBuf.AddValue(ValueToItem(I_LBRACKET, false));
              end;
          end;
          LastCharType:= E_LBRACKET;
        end;

      ')':     // prava zavorka
        begin
          case LastCharType of
            E_NUMBER:
              begin
                SetLastErrorCode( Num.GetValue(numResult));
                if GetLastErrorCode = ERR_OK then begin
                  ExprBuf.AddValue(ValueToItem(numResult, true));
                  ExprBuf.AddValue(ValueToItem(I_RBRACKET, false));
                end;
              end;
            E_NOTHING, E_BINOP, E_MINUS, E_FUNCTION, E_LBRACKET:
                SetLastErrorCode( ERR_ILL_RBRACKET);
            E_VAR, E_RBRACKET:
              ExprBuf.AddValue(ValueToItem(I_RBRACKET, false));
          end;
          LastCharType:= E_RBRACKET;
        end;

      'A'..'Z':
        if (strExpr[posExpr] in ['X', 'P', 'E']) then begin
            //promenna x  nebo konstanty pi, e
          case LastCharType of
            E_NUMBER:
              begin
                SetLastErrorCode( Num.GetValue(numResult));
                if GetLastErrorCode = ERR_OK then begin
                  ExprBuf.AddValue(ValueToItem(numResult, true));
                  ExprBuf.AddValue(ValueToItem(I_MUL, false));

                  if strExpr[posExpr] = 'X' then  //prom x
                    ExprBuf.AddValue(ValueToItem(I_VAR, false));

                  if (strExpr[posExpr] = 'P') then
                    if (posExpr+1 <= length(strExpr))
                      and (strExpr[posExpr+1] = 'I') then begin //konst pi
                        ExprBuf.AddValue(ValueToItem(I_PI, false));
                        inc(posExpr);  //!!!!! zvetsovani posExpr
                      end
                    else
                      SetLastErrorCode( ERR_ILL_LAST_CHAR);

                  if strExpr[posExpr] = 'E' then  //prom x
                    ExprBuf.AddValue(ValueToItem(I_E, false));
                end;
              end;
            E_NOTHING, E_BINOP, E_MINUS, E_LBRACKET:
              begin
                if (strExpr[posExpr] = 'X') then
                  ExprBuf.AddValue(ValueToItem(I_VAR, false));

                if (strExpr[posExpr] = 'P') then
                  if (posExpr+1 <= length(strExpr))
                    and (strExpr[posExpr+1] = 'I') then begin //konst pi
                      ExprBuf.AddValue(ValueToItem(I_PI, false));
                      inc(posExpr);  //!!!!! zvetsovani posExpr
                    end
                  else
                    SetLastErrorCode( ERR_ILL_LAST_CHAR);

                if strExpr[posExpr] = 'E' then  //prom x
                  ExprBuf.AddValue(ValueToItem(I_E, false));
              end;
            E_RBRACKET:
              begin
                ExprBuf.AddValue(ValueToItem(I_MUL, false));

                if (strExpr[posExpr] = 'X') then
                  ExprBuf.AddValue(ValueToItem(I_VAR, false));

                if (strExpr[posExpr] = 'P') then
                  if (posExpr+1 <= length(strExpr))
                    and (strExpr[posExpr+1] = 'I') then begin //konst pi
                      ExprBuf.AddValue(ValueToItem(I_PI, false));
                      inc(posExpr);  //!!!!! zvetsovani posExpr
                    end
                  else
                    SetLastErrorCode( ERR_ILL_LAST_CHAR);

                if strExpr[posExpr] = 'E' then  //prom x
                  ExprBuf.AddValue(ValueToItem(I_E, false));
              end;
            E_VAR, E_FUNCTION:
               SetLastErrorCode( ERR_ILL_VAR);
          end;
          LastCharType:= E_VAR;
        end

        else begin  //znak funkce
          case LastCharType of
            E_NUMBER:
              begin
                SetLastErrorCode( Num.GetValue(numResult));
                if GetLastErrorCode = ERR_OK then begin
                  ExprBuf.AddValue(ValueToItem(numResult, true));
                  ExprBuf.AddValue(ValueToItem(I_MUL, false));
                  Func.NewFunc(strExpr[posExpr]);
                end;
              end;
            E_VAR, E_RBRACKET:
              SetLastErrorCode( ERR_ILL_FUNCTION);
            E_NOTHING, E_BINOP, E_MINUS, E_LBRACKET:
              Func.NewFunc(strExpr[posExpr]);
            E_FUNCTION:
              Func.AddFunc(strExpr[posExpr]);
          end;
          LastCharType:= E_FUNCTION;
        end;

      '-':  //minus
        begin
          case LastCharType of
            E_NUMBER:
              begin
                SetLastErrorCode( Num.GetValue(numResult));
                if GetLastErrorCode = ERR_OK then begin
                  ExprBuf.AddValue(ValueToItem(numResult, true));
                  ExprBuf.AddValue(ValueToItem(I_MINUS, false));
                end;
              end;
            E_VAR, E_RBRACKET:
              ExprBuf.AddValue(ValueToItem(I_MINUS, false));
            E_NOTHING, E_LBRACKET:
              begin
                ExprBuf.AddValue(ValueToItem( -1, true));
                ExprBuf.AddValue(ValueToItem(I_MUL, false));
              end;
            E_FUNCTION, E_BINOP, E_MINUS:
              SetLastErrorCode( ERR_ILL_MINUS);
          end;
          LastCharType:= E_MINUS;
        end;
    else
      SetLastErrorCode( ERR_ILL_CHAR);
    end; //konec zakladniho case

    if GetLastErrorCode <> ERR_OK then
      begin
        Num.Close;
        Func.Close;
        ReadExpr:= posExpr; //vraci pozici na ktere je chyba,
                            //typ chyby se da zjistit z LastErrorCode

        exit;
      end;
    inc(posExpr);
  end; //konec cyklu while

  if LastCharType = E_NUMBER then begin //je posledni znak cast cisla
    SetLastErrorCode( Num.GetValue(numResult));
    if GetLastErrorCode = ERR_OK then
      ExprBuf.AddValue(ValueToItem(numResult, true));
  end;

  if LastCharType in [E_BINOP, E_MINUS, E_FUNCTION, E_LBRACKET] then
    SetLastErrorCode( ERR_ILL_LAST_CHAR);   //je posl znak binarni operator?

  Num.Close;
  Func.Close;

  if GetLastErrorCode = ERR_OK then begin  //je zatim vse dobre?
    if CheckBracketsCount(ExprBuf) then begin//kontrola zavorek
      ReadExpr:= 0;
      LoadedExpr:= strExpr;
    end
    else begin
      SetLastErrorCode( ERR_BAD_BRACKETS);
      ReadExpr:= length(strExpr);
    end;
  end
  else
    ReadExpr:= length(strExpr);
end;  // ***************  konec fce ReadExpr **************


function TFunctionEval.GetLoadedExpr: string;
begin
  GetLoadedExpr:= LoadedExpr;
end;

constructor TFunctionEval.Create;
begin
  bPostFixConv:= false;
  SetLastErrorCode( ERR_OK);
  LoadedExpr:= '';
  ExprBuf:= TBuffer.Create(BUFFER_SIZE);
  EvalBuf:= TBuffer.Create(BUFFER_SIZE);
  CountBuf:= TBuffer.Create(BUFFER_SIZE);
end;


destructor  TFunctionEval.Close;
begin
  ExprBuf.Close;
  EvalBuf.Close;
  CountBuf.Close;
end;

/// ^^***********************  TFunctionEval *******************************^^

//////////////  ***  TBuffer  ****

constructor TBuffer.Create(MaxSize: integer);
begin
  Size:=0;

  if MaxSize > MAX_BUFFER_SIZE/sizeof(TItem) then
    MaxSize:= trunc(MAX_BUFFER_SIZE/sizeof(TItem));

  AllocatedSize:= MaxSize;

  try
    GetMem(pBuffer, MaxSize* sizeof(TItem));
    GetMem(pTempBuffer, MaxSize* sizeof(TItem));
  except
    on EOutOfMemory do begin
      Application.MessageBox(
        'Nedostatek paměti pro vytvoření bufferu, program bude ukončen!',
        'Chyba!');
      halt(1);
    end;
  end;
end;


destructor TBuffer.Close;
begin
  if pBuffer <> nil then
    FreeMem(pBuffer, AllocatedSize* sizeof(TItem));
  if pTempBuffer <> nil then
    FreeMem(pTempBuffer, AllocatedSize * sizeof(TItem));
end;


procedure TBuffer.AddValue(Item: TItem);
  //prida do aktivniho bufferu 1 hodnotu
begin
  inc(Size);
  if Size <= AllocatedSize then
    pBuffer^[Size]:= Item
  else
    SetLastErrorCode( ERR_WRITE_BEHIND_BUFFER);
end;


procedure TBuffer.NewBuf;
begin
  Size:= 0;
end;


function TBuffer.GetValue(ItemNum:integer):TItem;
begin
  if ItemNum <= Size then
    GetValue:= pBuffer^[ItemNum]
  else
    SetLastErrorCode( ERR_READ_BEHIND_BUFFER)
end;


procedure TBuffer.SetValue(ItemNum:integer; Item:TItem);
begin
  if ItemNum <= AllocatedSize then begin
    if ItemNum > Size then
      Size:= ItemNum;
    pBuffer^[ItemNum]:= Item;
  end
  else
    SetLastErrorCode( ERR_WRITE_BEHIND_BUFFER)
end;


function TBuffer.GetSize: integer;
begin
  GetSize:= Size
end;

procedure TBuffer.SetSize(nSize: integer);
begin
  Size:= nSize;
end;

function TBuffer.FindFirst(What: integer): integer;
begin
  LastFound:= 0;
  FindFirst:= FindNext(What);
end;

function TBuffer.FindNext(What: integer): integer;
//hleda v bufferu znak a vraci jeho pozici, pokud se tam nenachazi vraci 0
//hleda od posledne nalezeneho znaku
var
  posf: integer;
  Item: TItem;
  bFound: boolean;
begin
  posf:= LastFound;
  bFound:= false;

  while (posf + 1 <= Size) and (not bFound) do begin
    Item:= GetValue(posf + 1);
    bFound:=  (not Item.IsNumber) and (Trunc(Item.Value) = What);
    inc(posf);
  end;

  if bFound then
    LastFound:= posf
  else
    LastFound:= 0;

  FindNext:= LastFound;
end;

procedure TBuffer.DeleteItems(From, Count: integer);
begin
  if From <= Size then begin
    if From + Count - 1 > Size then
      Count:=Size - From + 1;

    Move(
      pBuffer^[From + Count] {(From-1 + Size-1)*sizeof(TItem)},
      pTempBuffer^[1]{ + (From-1) *sizeof(TItem)},
      (Size - (From + Count -2))  * sizeOf(TItem));

    Move(
      pTempBuffer^[1] {(From-1 + Size-1)*sizeof(TItem)},
      pBuffer^[From]{ + (From-1) *sizeof(TItem)},
      (Size - (From + Count -2))  * sizeOf(TItem));

    Size:= Size - Count;
  end;
end;

//////////////  ***  TExprNumber  ****

constructor TExprNumber.Create;
begin
  posNumber:= 0;
end;

destructor  TExprNumber.Close;
begin
end;


procedure TExprNumber.AddNum(Digit: char);
begin
  inc(posNumber);
  strNumber:= strNumber + Digit;
end;


procedure TExprNumber.NewNum(Digit: char);
begin
  posNumber:= 1;
  strNumber:= Digit;
end;


function  TExprNumber.GetValue(var Value: extended): integer;
  //prevede cislo ulozene v strNumber a pokud nastane chyba
  //tak vraci nenulovy chybovy kod
var
  err: integer;
begin
  err:= ERR_OK;

  try
    Value:= StrToFloat(strNumber);
  except
    on EConvertError do err:= ERR_NUM_CONVERT;
  end;

  SetLastErrorCode( err);
  GetValue:= err;
end;


//////////////  ***  TExprFunction  ****

constructor TExprFunction.Create;
begin
  posFunc:= 0;
end;

destructor  TExprFunction.Close;
begin

end;


procedure TExprFunction.AddFunc(FuncChar: char);
begin
  inc(posFunc);
  strFunc:=strFunc + FuncChar;
end;


procedure TExprFunction.NewFunc(FuncChar: char);
begin
  posFunc:= 1;
  strFunc:= FuncChar;
end;


function TExprFunction.GetFunc(var FuncNum: integer): integer;
  //zkontroluje nactenou fci se seznamem fci a pokud ji nenejde
  //vraci nenulovy chybovy kod
begin

  FuncNum:= I_SIN;
  while (FuncNum <= I_FACT) and not(FUNCTIONS[FuncNum] = strFunc) do
    inc(FuncNum);

  if FUNCTIONS[FuncNum] = strFunc then
    GetFunc:= ERR_OK
  else begin
    FuncNum:= 0;
    GetFunc:= ERR_FUNC_CONVERT;
    SetLastErrorCode( ERR_FUNC_CONVERT);
  end;
end;


////////////////////// ***** ostatni fce  *****

function GetBinOpNumber(BinOp: char): integer;
var
  nResult: integer;
begin
  case BinOp of
    '-': nResult:= I_MINUS;
    '+': nResult:= I_PLUS;
    '*': nResult:= I_MUL ;
    '/': nResult:= I_DIV ;
    '^': nResult:= I_POWER;
  else
    nResult:= 0;
  end;

  GetBinOpNumber:= nResult;
end;


function ValueToItem(Value: extended; IsNumber: boolean): TItem;
var
  pomItem: TItem;
begin
  pomItem.Value:= Value;
  pomItem.IsNumber:= IsNumber;
  ValueToItem:= pomItem;
end;


procedure CopyActiveBuffer(var TargBuf: TBuffer; const SourBuf: TBuffer);
//procedura okopiruje obsah aktivniho bufferu z SourBuf do TargBuf
//a nastavi delku
//!! v TargBuf jiz musi byt buffery alokovane
var
  size: integer;
begin
  size:= SourBuf.GetSize;
  TargBuf.SetSize(size);

  Move(SourBuf.pBuffer^[1], TargBuf.pBuffer^[1], Size * sizeof(TItem));
end;



////////// **********  TStack *************************
constructor TStack.Create;
begin
  pTop:= nil;
end;


destructor  TStack.Close;
var
  ptr: pTStItem;
begin
  while pTop <> nil do begin
    ptr:= pTop^.pLower;
    Dispose(pTop);
    pTop:= ptr;
  end;
end;


function   TStack.IsEmpty: boolean;
begin
  IsEmpty:= pTop = nil;
end;


procedure  TStack.Push(It: TItem);
var
  ptr: pTStItem;
begin
  New(ptr);
  ptr^.It:= It;
  ptr^.pLower:= pTop;
  pTop:= ptr;
end;


function   TStack.Top: TItem;
begin
  if pTop <> nil then
    Top:= pTop^.It
  else begin
    SetLastErrorCode( ERR_STACK_TOP);
    Top:= ValueToItem(0, true);
  end;
end;


function  TStack.TopPop: TItem;
var
  ptr: pTStItem;
begin
  if pTop <> nil then begin
    TopPop:= pTop^.It;
    ptr:= pTop^.pLower;
    Dispose(pTop);
    pTop:= ptr;
  end

  else begin
    SetLastErrorCode( ERR_STACK_TOPPOP);
    TopPop:= ValueToItem(0, true);
  end;
end;


end.