Vyhodnocení aritmetického výrazu soustavou procedur ve vztahu nepřímé rekurze podle formální gramatiky stavby výrazu

{ ARITMETICKT_VYRAZ.PAS                                             }
{ Vyhodnoceni aritmetickeho vyrazu soustavou procedur ve vztahu     }
{ neprime rekurze podle formalni gramatiky stavby vyrazu.           }
{                                                                   }
{ Datum:13.07.2013                             http://www.trsek.com }
 
program AritmetVyraz;
uses crt;
const
    MAX_CONST = 10;     { velkost bufera konstant }
    ERR_SIGN  = 'Vyskytli sa 2 znamienka za sebou';
    ERR_UNCMP = 'Chyba clen pre matematicku operaciu';
    DIV_ZERO  = 'Nastalo delenie nulou';
    ERR_BRK_L = 'Nespravny pocet zatvoriek, chyba lava zatvorka';
    ERR_BRK_R = 'Nespravny pocet zatvoriek, chyba prava zatvorka';
    ERR_UNK   = 'Neznama funkcia :';
 
var S: string;             { ulozeni vyhodnocovaneho vyrazu }
    pError: integer;       { pozicia chyby }
    sError: string;        { popis chyby   }
    vys: real;             { vysledok vyrazu }
 
    nameC:array[1..MAX_CONST] of string;
    realC:array[1..MAX_CONST] of real;
 
 
{ funkce vyhodnocujici artitmeticky vyraz              }
{ metoda - neprima rekurze funkci Vyraz, Clen, Faktor  }
{ vyhodnocovany vyraz je zadan ve vstupnim parametru S }
{ funkce predpoklada, ze vyraz je syntakticky spravny  }
function Vyhodnoceni(S:string): real;
var poz:integer;   { na akej pozicii vo vyraze }
 
  function Vyraz(var S: string): real;
    forward;
 
 
  { zmaz prvy znak }
  { zaroven si pamata kolko znakov od zaciatku sa nachadza, premena p }
  procedure DeleteOne(var S:string);
  begin
    inc(poz);
    Delete(S,1,1);
  end;
 
 
  {zmaze zbytocne mezery}
  procedure BezMezer(var s:string);
  begin
    while(s[1]=' ') do DeleteOne(s);
  end;
 
 
  { ulozi si chybovy stav }
  procedure PutError(error:string);
  begin
    { ak uz neaka chyba je tak nic }
    if( pError=0 )then
      begin
        pError:=poz;
        sError:=error;
      end;
  end;
 
 
  { zisti cele cislo, take co sa sklada iba z 0..9 }
  function CeleCislo(var S:string):integer;
  var H:integer;
  begin
    H := 0;
 
    while S[1] in ['0'..'9'] do
    begin
      H := H * 10 + ord(S[1]) - ord('0');
      DeleteOne(S);
      BezMezer(S);
    end;
 
    CeleCislo:=H;
  end;
 
 
  { prevrati na desatinu cast }
  function Desatine(H:real):real;
  begin
    while(Int(H)>0) do
      H := H/10;
 
    Desatine := H;
  end;
 
 
  { zisti cislo int/real }
  { prisiel sem lebo string zacial cislom 0..9 }
  function MakeNumber(var S:string):real;
  var H: real;        {skutocne cislo}
  begin
    H := CeleCislo(S);
 
    { bude desatina cast, realne cislo }
    if(S[1] = '.')then
    begin
      DeleteOne(S);
      H := H + Desatine( CeleCislo(S));
    end;
 
    { cislo s exponentom }
    if(UpCase(S[1]) = 'E')then begin
      DeleteOne(S);
 
      { kladny exponent }
      if(S[1]='+')then begin
         DeleteOne(S);
         H:=H * Exp(CeleCislo(S)*Ln(10));
      end;
 
      { zaporny exponent }
      if(S[1]='-')then begin
         DeleteOne(S);
         H:=H / Exp(CeleCislo(S)*Ln(10));
      end;
 
	    { ziadny exponent }
	    if(S[1] in ['0'..'9'])then
	       H:=H * Exp(CeleCislo(S)*Ln(10));
    end;
 
    MakeNumber := H;
  end;
 
 
  { vykona funkciu }
  function MakeFunc(name:string; H:real):real;
  var K:boolean;   { pozna taku funkciu }
  begin
    K:=true;
 
    if(name='SIN'   )then begin MakeFunc := sin(H);  K:=false; end;
    if(name='COS'   )then begin MakeFunc := cos(H);  K:=false; end;
    if(name='INT'   )then begin MakeFunc := int(H);  K:=false; end;
    if(name='ABS'   )then begin MakeFunc := abs(H);  K:=false; end;
    if(name='SQRT'  )then begin MakeFunc := sqrt(H); K:=false; end;
    if(name='LN'    )then begin MakeFunc := ln(H);   K:=false; end;
    if(name='LOG'   )then begin MakeFunc := ln(H)/ln(10);  K:=false; end;
    if(name='TAN'   )then begin MakeFunc := sin(x)/cos(x); K:=false; end;
    if(name='COTAN' )then begin MakeFunc := cos(x)/sin(x); K:=false; end;
    if(name='ARCTAN')then begin MakeFunc := arctan(H); K:=false; end;
 
    { taku fuknciu nema definovanu }
    if(K)then
      PutError( ERR_UNK + name );
 
  end;
 
 
  { vypita si hodnotu konstaty }
  { ak uz taka je v zozname vrati jej hodnotu }
  function GetConst(name:string):real;
  var i: integer;
  begin
    i:=1;
 
    { najdeme taky s nazvom name }
    while((nameC[i]<>name) and (nameC[i]<>'')
         and (i<MAX_CONST)) do
      inc(i);
 
    { nenasiel nic }
    if((nameC[i]='') or (i=MAX_CONST))then begin
       nameC[i]:=name;
       Write('Zadaj hodnotu konstanty ',name,'=');
       ReadLn(realC[i]);
    end;
 
    GetConst:=realC[i];
  end;
 
 
  { zistuje nazvy funkcii }
  function FindFunc(var S:string):real;
  var name: string;
      H: real;
  begin
    FindFunc := 0;
    name := '';
 
    while S[1] in ['A'..'z'] do
    begin
      name := name + UpCase(S[1]);
      DeleteOne(S);
    end;
 
    BezMezer(S);
    { skoncil text }
    { ak bude pokracovat text je to funkcia, inac konstanta }
    if S[1] = '(' then
     begin
      DeleteOne(S);       {zrusit levou zavorku}
      FindFunc := MakeFunc(name, Vyraz(S));
 
      { ocakavam pravu zatvorku }
      if S[1] <> ')' then
         PutError( ERR_BRK_R )
      else
         DeleteOne(S);       {zrusit pravou zavorku}
     end
    else
     if name<>'' then
        FindFunc:=GetConst(name);
 
  end;
 
 
  {pomocna funkce na vyhodnoceni jednoho faktoru}
  {faktorem je ciselna hodnota nebo vyraz v zavorkach}
  function Faktor(var S: string): real;
  var M:integer;
  begin
    BezMezer(S);
 
    { vyraz nesmie zacinat pravou zatvorkou }
    if S[1] = ')' then
      PutError( ERR_BRK_L );
 
    if S[1] = '(' then
     begin
      DeleteOne(S);       {zrusit levou zavorku}
      Faktor := Vyraz(S);
 
      { ocakavam pravu zatvorku }
      if S[1] <> ')' then
         PutError( ERR_BRK_R )
      else
         DeleteOne(S);       {zrusit pravou zavorku}
     end
    else  {ciselna konstanta}
     begin
      BezMezer(S);
 
      { je to zaporne cislo? }
      M:=1;
      if( S[1]='-' )then begin M:=-1; DeleteOne(S);end;
 
      { Faktor nesmie zacinat znamienkom }
      if( S[1] in ['+','-','*','/'])then
       begin
        if( poz=1 )then
           PutError( ERR_UNCMP )
         else
           PutError( ERR_SIGN );
        end;
 
      if(S[1] in ['0'..'9'])then
        { hladaj cislo }
        Faktor := M*MakeNumber(S)
      else
       begin
        { hladaj konstantu, alebo nazov funkcie }
        if S[1] = '(' then
           Faktor := M*Faktor(S)        { mala rekururzia }
        else
           Faktor := M*FindFunc(S);
       end;
     end;
  end;
 
 
  {pomocna funkce na vyhodnoceni jednoho clenu}
  {clenem je jeden faktor nebo soucin/podil vice faktoru}
  function Clen(var S: string): real;
  var C: real;        {hodnota clenu}
      FC: real;       {aby som mohol kontrolovat ze nedeli nulov}
  begin
    BezMezer(S);
    C := Faktor(S);
 
    BezMezer(S);
    while S[1] in ['*','/'] do
    begin
      if S[1] = '*' then        {soucin faktoru}
        begin
        DeleteOne(S);
        C := C * Faktor(S);
      end;
 
      if S[1] = '/' then        {podil faktoru}
        begin
        DeleteOne(S);
        FC := Faktor(S);
 
        if(FC<>0)then C := C/FC
                 else PutError(DIV_ZERO);
      end;
    end;
 
    Clen := C
  end;
 
 
  { funkce na vyhodnoceni vyrazu           }
  { vyraz je clen nebo soucet/rozdil clenu }
  function Vyraz(var S: string): real;
  var V: real;       {hodnota vyrazu}
  begin
    V := Clen(S);
    BezMezer(S);
 
    while S[1] in ['+','-'] do
    begin
      if S[1] = '+' then        {soucet clenu}
        begin
        DeleteOne(S);
        V := V + Clen(S);
      end;
 
      if S[1] = '-' then        {rozdil clenu}
        begin
        DeleteOne(S);
        V := V - Clen(S);
      end;
    end;
 
    Vyraz := V
  end;
 
 
  begin {function Vyhodnoceni}
    pError := 0;
    poz    := 1;
 
    S := S + '$';                {technicky trik pro ukonceni}
    Vyhodnoceni := Vyraz(S);
 
    { zostala neaka zatvorka, alebo iny znak ? }
    BezMezer(S);
    if S[1]=')' then PutError( ERR_BRK_L );
    if S[1]='(' then PutError( ERR_BRK_R );
    if S[1]<>'$' then PutError( ERR_UNK );
 
  end;  {function Vyhodnoceni}
 
 
begin
  repeat
    writeln;
    textcolor(blue);
    writeln('Program vyhodnocuje aritmeticky vyraz.');
    writeln;
    textcolor(white);
    writeln('Uzivatel moze pracovat s realnymi cislami-zadavaju sa v tvare 25.3E+4.');
    writeln('Ak uzivatel zada realne cislo v tvare 25.3E4,');
    writeln('program ho vyhodnocuje ako cislo s kladnym exponentom.');
    writeln;
    writeln('Uzivatel moze pouzivat premenne (pismena anglickej abecedy).');
    writeln('Moze ich byt maximalne 10.':58);
    writeln;
    writeln('Uzivatel moze pouzivat funkcie: sin, cos, int, abs a sqrt.');
    writeln;
    writeln('Uzivatel moze urobit v zadani nasledovne chyby:');
    writeln(' - 2 znamienka za sebou alebo bude chybat clen');
    writeln(' - delenie nulou');
    writeln(' - nespravny pocet zatvoriek-chyba prava alebo lava zatvorka');
    writeln(' - neznama funkcia');
    writeln;
    writeln('Program uzivatelovi oznami druh a poziciu chyby aby to uzivatel mohol opravit.');
    writeln;
    writeln;
    textcolor(blue);
    write('Napis vyhodnocovany vyraz:');
    textcolor(yellow);
 
    readln(S);
    vys:=Vyhodnoceni(S);
 
    if(pError<>0)then
       writeln('Cyba na pozicii ',pError,'->',sError)
    else
       writeln('Hodnota vyrazu: ', vys:0:5 );
  until( pError=0 );
 
  readln
end.