Zobrazí 2D graf funkcie ktoru zadá užívatel z klávesnice

{ GRAF.PAS                  Copyright (c) TrSek alias Zdeno Sekerak }
{ Vykreslenie grafu zo zadaneho matematickeho vyrazu.               }
{ Program obsahuje analyzator matematickeho vyrazu a jeho vycislenie.}
{                                                                   }
{ Datum:21.05.2005                             http://www.trsek.com }
 
program Graf;
uses crt,graph;
 
const LEFTW = 150;           { kolko pixelov vynechat zlava }
      DOWNW = 20;            { kolko pixelov vynechat zdola }
 
var     S: string;           { vyhodnocovany vyraz }
      vys: real;             { vysledok vyrazu     }
    chyba: integer;          { pozicia chyby       }
    gd,gm: integer;          { pre inicializaciu grafiky }
      fnc: array[1..9] of string;  { pole funkcii }
  x,y1,y2: real;
      err: integer;          { nepodstane len pre chytanie chyb vo VAL }
     krok: real;
       ch: char;             { stlacenie klavesy }
   fi, poc_fi: integer;      { pocet funkcii }
  zac_x,kon_x: real;
  zac_y,kon_y: real;
 
 
procedure EGAVGA_dr; external;
{$L EGAVGA.OBJ }
 
 
{ inicializacia grafickej karty }
procedure InitGr;
begin
  RegisterBGIdriver(@egavga_dr);
  gd := Detect;
  gm:=1;
  InitGraph(gd, gm,' ');
end;
 
 
{ prepocita suradnice a vykresli ak sa da }
procedure trans_line( x1,y1,x2,y2:real);
var mx,my:real;
begin
  { aby nebola os y zrkadlovo otocena }
  y1:=(-1)*y1;
  y2:=(-1)*y2;
 
  { prepocet mierky }
  mx:=(kon_x-zac_x)/(GetMaxX-LEFTW);
  my:=(kon_y-zac_y)/(GetMaxY-DOWNW);
 
  { prepocet na obrazovkove suradnice }
  x1:=(x1-zac_x)/mx;
  x2:=(x2-zac_x)/mx;
  y1:=(y1-zac_y)/my;
  y2:=(y2-zac_y)/my;
 
  { nakresli line }
  line(round(x1),round(y1),round(x2),round(y2));
end;
 
 
{ prepocita suradnice x,y pre potreby OutTextXY }
{ pozor vypocet musi byt zhodny ako v trans_line }
procedure Trans_XY(var x,y:real);
var mx,my:real;
begin
  { aby nebola os y zrkadlovo otocena }
  y:=(-1)*y;
 
  { prepocet mierky }
  mx:=(kon_x-zac_x)/(GetMaxX-LEFTW);
  my:=(kon_y-zac_y)/(GetMaxY-DOWNW);
 
  { prepocet na obrazovkove suradnice }
  x:=(x-zac_x)/mx;
  y:=(y-zac_y)/my;
end;
 
 
{ prevod cisla na text }
function ToStr(chyba:integer):string;
var s:string;
begin
  Str(chyba,s);
  ToStr:=s;
end;
 
 
{ prevod cisla real na text }
function RToStr(i:real):string;
var s:string;
begin
  Str(i:0:2,s);
  RToStr:=s;
end;
 
 
{ zisti aky je optimalny krok mierky }
function KrokMierky(d:real):real;
var rad:integer;
begin
  rad:=0;
  d:=d/5;
 
  { budeme zmensovat az po rad 10 }
  while(d>10) do begin
    inc(rad);
    d:=d/10;
  end;
 
  { alebo budeme zvacsovat az po rad 10 }
  while(d<1) do begin
    dec(rad);
    d:=d*10;
  end;
 
  if(d<2)then d:=1;
  if((d>=2) and (d<4))then d:=2.5;
  if((d>=4) and (d<6))then d:=5;
  if((d>=6) and (d<8))then d:=7.5;
  if(d>8)then d:=10;
 
  { spat zvacsime }
  while(rad>0) do begin
    dec(rad);
    d:=d*10;
  end;
 
  { alebo spat zmensime }
  while(rad<0) do begin
    inc(rad);
    d:=d/10;
  end;
 
  KrokMierky:=d;
end;
 
 
 
{ vykresli od }
procedure VykresliOsi;
var krokx, kroky:real;
    mx,my:real;
    i,x,y:real;
begin
  { zisti optimalny krok mierky }
  krokx := KrokMierky(kon_x-zac_x);
  kroky := KrokMierky(kon_y-zac_y);
 
  SetColor(green);
 
  { osovy kriz }
  trans_line( 0,zac_y,0,kon_y);
  trans_line( zac_x,0,kon_x,0);
 
  { ramcek okolo osi }
  trans_line( zac_x, zac_y, kon_x, zac_y );
  trans_line( zac_x, kon_y, kon_x, kon_y );
  trans_line( zac_x, zac_y, zac_x, kon_y );
  trans_line( kon_x, zac_y, kon_x, kon_y );
 
  { cisla mierky x }
  i:=zac_x;
  repeat
    x:=i; y:=0;
    trans_XY(x,y);
    line(round(x),round(y+3),round(x),round(y-3));
    OutTextXY( round(x-10), round(y+13), RToStr(i));
    i:=i+krokx;
  until (i>=kon_x);
 
  { cisla mierky y }
  i:=zac_y;
  repeat
    x:=0; y:=i;
    trans_XY(x,y);
    line(round(x-3),round(y),round(x+3),round(y));
    OutTextXY( round(x+8), round(y-3), RToStr(i));
    i:=i+krokx;
  until (i>=kon_y);
end;
 
 
 
{ funkcia vyhodnoti zadany vyraz }
function Vypocitaj(S:string; x:real; var chyba:integer): real;
var poz:integer;   { pozicia spracovanie znaku }
 
  function Vyraz(var S: string): real;
    forward;
 
  { zmaze jeden znak }
  { zaroven si pamata kolko znakov zmazal }
  procedure DeleteOne(var S:string);
  begin
    inc(poz);
    Delete(S,1,1);
  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);
    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;
 
    { novu funkciu staci definovat sem }
    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 funkciu nema definovanu }
    if(K)then
      chyba:=poz;
  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;
 
    { skoncil text }
    { ak bude pokracovat text je to funkcia }
    if S[1] = '(' then
     begin
      DeleteOne(S);       {zrusit levou zavorku}
      FindFunc := MakeFunc(name, Vyraz(S));
 
      { ocakavam pravu zatvorku }
      if S[1] <> ')' then
         chyba:=poz
      else
         DeleteOne(S);       {zrusit pravou zavorku}
     end
     { ak je to x tak OK inac chyba }
     else begin
      if( name='X' )then
         FindFunc:=x
      else
         chyba:=poz;
     end;
  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
    { vyraz nesmie zacinat pravou zatvorkou }
    if S[1] = ')' then
      chyba:=poz;
 
    if S[1] = '(' then
     begin
      DeleteOne(S);       {zrusit levou zavorku}
      Faktor := Vyraz(S);
 
      { ocakavam pravu zatvorku }
      if S[1] <> ')' then
         chyba:=poz
      else
         DeleteOne(S);       {zrusit pravou zavorku}
     end
    else  {ciselna konstanta}
     begin
      { 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
        chyba:=poz;
 
      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
    C := Faktor(S);
 
    while S[1] in ['*','/'] do
    begin
      if S[1] = '*' then begin    {sucin faktorov}
        DeleteOne(S);
        C := C * Faktor(S);
      end;
 
      if S[1] = '/' then begin    {podiel faktorov}
        DeleteOne(S);
        FC := Faktor(S);
        if(FC<>0)then C := C/FC
                 else chyba:=-1;
      end;
    end;
 
    Clen := C
  end;
 
 
  { funkce na vyhodnotenie vyrazu              }
  { vyraz je clen aleboo soucet/rozdiel clenov }
  function Vyraz(var S: string): real;
  var V: real;       {hodnota vyrazu}
  begin
    V := Clen(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 {function Vypocitaj}
    poz   := 1;
    S := S + '$';                {technicky trik pro ukonceni}
    Vypocitaj := Vyraz(S);
 
    { zostal este neaky znak, potom je to chyba }
    if S<>'$' then chyba:=poz;
 
  end;  {function Vypocitaj}
 
 
 
{ zobrazi lave menu programu }
procedure LeftMenu;
var x,i:integer;
begin
  x:=GetMaxX-LEFTW+10;
 
  OutTextXY(x,10,'Os-x od:'+ RToStr(zac_x));
  OutTextXY(x,30,'Os-x do:'+ RToStr(kon_x));
  OutTextXY(x,50,'Os-y od:'+ RToStr(zac_y));
  OutTextXY(x,70,'Os-y do:'+ RToStr(kon_y));
 
  { vypiseme funkcie }
  for i:=1 to poc_fi do
  begin
    SetColor(i+3);
    OutTextXY(x,100+i*20, 'f'+ToStr(i)+':'+fnc[i]);
  end;
end;
 
 
 
{ Zobrazi pomoc s programom }
procedure HelpBar;
begin
  OutTextXY(3, GetMaxY-10,'<ESC>-End <A>-Add func <D>-Delete func <X>-X_zac <C>-X_kon <H>-Y_zac <Y>-Y_kon');
end;
 
 
{ precita hodnotu na udanej pozicii }
function GetValue(otazka:string):string;
var s:string;
begin
  SetColor(green);
  OutTextXY(GetMaxX-LEFTW+10, 280, otazka);
  GotoXY(65,22);
  ReadLn(s);
 
  GetValue:=s;
end;
 
 
{ otestuje ci je vsetko OK }
function TestPaint(y1,y2:real):boolean;
var IsOK:boolean;
begin
  TestPaint:=true;      { predpokladame ze to bude OK }
 
  { chyba spracovania vyrazu }
  if( chyba>0 )then begin
      OutTextXY(10,fi*15,'Fnc:'+ToStr(fi)+' chyba na pozicii:'+ToStr(chyba));
      TestPaint:=false;
  end;
 
  { nastalo delenie nulou alebo tak podobne }
  if( chyba<0 )then
      TestPaint:=false;
 
  { taky easy test na spojitost }
  if(( y1<zac_y ) or (y1>kon_y) or
     ( y2<zac_y ) or (y2>kon_y))then
      TestPaint:=false;
end;
 
 
{ HLAVNY BEGIN }
begin
  zac_x:=-3; kon_x:=6;
  zac_y:=-8; kon_y:=8;
  fnc[1]:='2*cos(x)';
  fnc[2]:='1/(x*x)';
  fnc[3]:='sin(x)/cos(x)';
  poc_fi:=3;
 
  repeat
  InitGr;
  VykresliOsi;
  HelpBar;
  LeftMenu;
 
 
  for fi:=1 to poc_fi do
  begin
    { inicializujem farbu a zaciatok x, krok }
    SetColor(fi+3);
    s:=fnc[fi];
    chyba:=0;
 
    x:=zac_x;
    krok:=(kon_x-zac_x)/(GetMaxX-LEFTW);
 
    { vykreslim i-tu funkciu }
    repeat
      y1:=Vypocitaj(s,x,chyba);
      y2:=Vypocitaj(s,x+krok,chyba);
 
      { mozem to vykreslit }
      if( TestPaint(y1,y2))then
          trans_line( x,y1,x+krok,y2);
 
      x:=x+krok;
    until ((x>=kon_x) or (chyba>0));
  end;
 
  ch:=UpCase(readkey);
  if(ch='X')then Val( GetValue('Zadaj zac x:'), zac_x, err);
  if(ch='C')then Val( GetValue('Zadaj kon x:'), kon_x, err);
  if(ch='H')then Val( GetValue('Zadaj zac y:'), zac_y, err);
  if(ch='Y')then Val( GetValue('Zadaj kon y:'), kon_y, err);
 
  if(ch='A')then begin inc(poc_fi); fnc[poc_fi]:=GetValue('Zadaj funciu'); end;
  if(ch='D')then poc_fi:=0;
 
  { pockam na stlacenie keyb }
  until (ch=#27);
  CloseGraph;
end.