Program vykreslí graf funkcie zadanej z klávesnice v 3D priestore pričom dovolí tento graf otáčať v roznych osiach súmernosti (X,Y,Z), prípadne zvaščovať zmenšovať mierku zobrazenia

{ aritmet.pas               Copyright (c) TrSek alias Zdeno Sekerak  }
{ Unit na vyhodnotenie aritmetickeho vyrazu za pomoci rekurzii podla }
{ stavby vyrazu.                                                     }
{                                                                    }
{ Datum:17.09.2005                              http://www.trsek.com }
 
unit aritmet;
 
interface
uses crt;
 
var S: string;             { vyhodnocovany vyraz }
    vys: real;             { vysledok vyrazu }
    pError: integer;       { pozicia chyby }
 
function Vyhodnot(S:string;x,y:real): real;
 
 
implementation
 
{ Vyhodnocovany vyraz je vo vstupnom parametry S}
function Vyhodnot(S:string;x,y:real): real;
var poz:integer;   { vyhodnocovana pozicia }
 
  function Vyraz(var S: string): real;
    forward;
 
 
  { zmaz prvy znak }
  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;
  begin
    { ak uz neaka chyba je tak nic }
    if( pError=0 )then
        pError:=poz;
  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;
 
  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
      else
         DeleteOne(S);       {zrusit pravou zavorku}
     end
    else
     { je to x alebo y }
     if name<>'' then
     begin
       if( name='X' )then FindFunc:=x;
       if( name='Y' )then FindFunc:=y;
     end;
 
  end;
 
 
  { funkcia na vyhodnotenie faktoru }
  { faktorom je ciselna hodnota alebo vyraz v zatvorkach }
  function Faktor(var S: string): real;
  var M:integer;
  begin
    BezMezer(S);
 
    { vyraz nesmie zacinat pravou zatvorkou }
    if S[1] = ')' then
      PutError;
 
    if S[1] = '(' then
     begin
      DeleteOne(S);       {zrusit levu zatvorku}
      Faktor := Vyraz(S);
 
      { ocakavam pravu zatvorku }
      if S[1] <> ')' then
         PutError
      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
          PutError;
 
      if(S[1] in ['0'..'9'])then
        { hladaj cislo }
        Faktor := M*MakeNumber(S)
      else
        { hladaj nazov funkcie }
        Faktor := FindFunc(S);
     end;
  end;
 
 
  { funkcia na vyhodnocuje jeden clen }
  { clenom je faktor alebo soucin/podiel viacerych faktorov }
  function Clen(var S: string): real;
  var C: real;        { clen }
      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        {sucin faktorov}
        begin
        DeleteOne(S);
        C := C * Faktor(S);
      end;
 
      if S[1] = '/' then        {podiel faktorov}
        begin
        DeleteOne(S);
        FC := Faktor(S);
 
        if(FC<>0)then C := C/FC
                 else PutError;
      end;
    end;
 
    Clen := C
  end;
 
 
  { funkcia na vyhodnotenie vyrazu }
  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        {sucet clenov}
        begin
        DeleteOne(S);
        V := V + Clen(S);
      end;
 
      if S[1] = '-' then        {rozdiel clenov}
        begin
        DeleteOne(S);
        V := V - Clen(S);
      end;
    end;
 
    Vyraz := V
  end;
 
 
  begin
    pError := 0;
    poz    := 1;
 
    S := S + '$';               {technicky trik pre koniec }
    Vyhodnot := Vyraz(S);
 
    BezMezer(S);
 
    { zostala neaka zatvorka, alebo iny znak ? }
    if( S[1]<>'$' )then
        PutError;
  end;
 
 
begin
end.