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

{ GRAFMOVE.PAS              Copyright (c) TrSek alias Zdeno Sekerak  }
{ Program vykreslí graf funkcie y=10*sin(x)/cos(y) 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.                    }
{ Vykreslovaciu funkciu si program vyžiada z klávesnice.             }
{                                                                    }
{ Datum:13.07.2013                              http://www.trsek.com }
 
program graf_move;
uses crt,dos,graph,aritmet;
 
const KROK=5;     { sirka sietky a zaroven KROK_X, KROK_Y }
      KU=0.05;    { krok otacania v stupnoch }
      PI=3.1425;
 
 
var gd,gm:integer;
    x_zac, x_kon:real;       { rozsah x-ovej osi }
    y_zac, y_kon:real;       { rozsah y-ovej osi }
    z_zac, z_kon:real;       { rozsah z-ovej osi }
    alpha1,beta1:real;
    xo, yo:real;
    alpha,beta,gama,delta:real;
    fnc:string;              { vyhodnocovana funkcia }
    ch :char;
 
procedure EGAVGA_dr; external;
{$L EGAVGA.OBJ }
 
 
{ prepocita suradnice na mierku zvolenu uzivatelom }
function MierkaX(x:real; smer:byte):real;
var p1,p2:real;
begin
  p1:=GetMaxX div 2;
  p2:=x_kon-x_zac;
 
  if( smer=1 )then
    MierkaX:=x*p1/p2
  else
    MierkaX:=x*p2/p1;
end;
 
 
{ prepocita suradnice na mierku zvolenu uzivatelom }
function MierkaY(x:real; smer:byte):real;
var p1,p2:real;
begin
  p1:=GetMaxY div 3;
  p2:=y_kon-y_zac;
 
  if( smer=1 )then
    MierkaY:=x*p1/p2
  else
    MierkaY:=x*p2/p1;
end;
 
 
{ prepocita suradnice na mierku zvolenu uzivatelom }
function MierkaZ(x:real; smer:byte):real;
var p1,p2:real;
begin
  p1:=GetMaxY div 3;
  p2:=z_kon-z_zac;
 
  if( smer=1 )then
    MierkaZ:=x*p1/p2
  else
    MierkaZ:=x*p2/p1;
end;
 
 
{ prevod z cisla na retazec }
function ToStr(x:real):string;
var s:string;
  err:integer;
begin
  if((x>0) and (x<1))then
    Str(x:2:3,s)
  else
    Str(x:2:0,s);
 
  ToStr:=s;
end;
 
 
{ definicia funkcie }
function funcXY(x,y:real;var corr:boolean):real;
var vys: real;
begin
  corr:=false;
  funcXY:=0;
 
  x:=MierkaX(x,2);
  y:=MierkaY(y,2);
 
  vys:=Vyhodnot(fnc,x,y);
 
  { iba ak nieje ziadna chyba }
  if(pError=0)then
  begin
    corr:=true;
    funcXY:=MierkaZ(vys,1);
  end
end;
 
 
{ GetX - vypocita x suradnicu vramci prevodu 3D->2D }
procedure GetXY(x,y,z:real;var xr1,yr1:real);
var XX0,YY0,ZZ0:real;
    XX,YY,ZZ:real;
begin
  XX:=x;
  YY:=(y*cos(alpha)+z*sin(alpha));
  ZZ:=(-y*sin(alpha)+z*cos(alpha));
 
  XX0:=XX;
  YY0:=YY;
  ZZ0:=ZZ;
 
  XX:=(XX0*cos(beta)-ZZ0*sin(beta));
  YY:=YY0;
  ZZ:=(XX0*sin(beta)+ZZ0*cos(beta));
 
  XX0:=XX;
  YY0:=YY;
  ZZ0:=ZZ;
 
  XX:=(XX0*cos(gama)-YY0*sin(gama));
  YY:=(XX0*sin(gama)+YY0*cos(gama));
  ZZ:=ZZ0;
 
  xr1:=(xo-YY*cos(beta1*pi/180)+XX*cos(alpha1*pi/180));
  yr1:=(yo+YY*sin(beta1*pi/180)+XX*sin(alpha1*pi/180)+ZZ);
end;
 
 
{ vykresli ciaru transformovanu 3D na 2D }
procedure mline(x1,y1,z1,x2,y2,z2:real);
var xr1,yr1:real;
    xr2,yr2:real;
    kresli:boolean;
begin
  kresli:=true;
 
  { prepocet x,y suradnic }
  GetXY(x1,y1,z1,xr1,yr1);
  GetXY(x2,y2,z2,xr2,yr2);
 
  { ak by bola ciara mimo obrazovku }
  if(( xr1<0 ) or (xr2<0) or
     ( yr1<0 ) or (yr2<0)) then kresli:=false;
 
  { ak by bola ciara mimo obrazovku }
  if(( xr1>GetMaxX ) or (xr2>GetMaxX) or
     ( yr1>GetMaxY ) or (yr2>GetMaxY)) then kresli:=false;
 
  if( kresli )then
      line( round(xr1), round(yr1), round(xr2), round(yr2));
end;
 
 
{ program na vyvolene cisla mierky }
function VyvolCislo(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;
 
  { 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 }
  while(rad>0) do begin
    dec(rad);
    d:=d*10;
  end;
 
  while(rad<0) do begin
    inc(rad);
    d:=d/10;
  end;
 
  VyvolCislo:=d;
end;
 
 
{ nakresli osovy kriz }
procedure oskriz;
var i,krok_i:real;
     xr1,yr1:real;
begin
  { ideme kreslit mierku x }
  SetColor(Red);
  mline( 0,0,0, GetMaxX div 2,0,0 );   { os x }
 
  i:=0;
  krok_i:=VyvolCislo(x_kon-x_zac);
 
  repeat
    mline( MierkaX(i,1),3,0, MierkaX(i,1),-3,0);
    GetXY( MierkaX(i,1),-12,0, xr1,yr1);
    OutTextXY( round(xr1), round(yr1), ToStr(i));
 
    i:=i+krok_i;
  until (i>=x_kon);
 
 
  { ideme kreslit mierku y }
  SetColor(Green);
  mline( 0,0,0, 0,GetMaxY div 3,0 );   { os y }
 
  i:=0;
  krok_i:=VyvolCislo(y_kon-y_zac);
 
  repeat
    mline( 3, MierkaY(i,1),0, -3, MierkaY(i,1),0);
    GetXY( -20, MierkaY(i,1),0, xr1,yr1);
    OutTextXY( round(xr1), round(yr1), ToStr(i));
 
    i:=i+krok_i;
  until (i>=y_kon);
 
  { os y len vykreslime }
  SetColor(Yellow);
  mline( 0,0,0, 0,0,GetMaxY div 3 );   { os z podobne ako y lebo je kratsia }
 
  SetColor(White);
end;
 
 
{ vykresli obe grafy }
procedure KresliGraf;
var x,y  :real;
    z1,z2:real;
    c1,c2:boolean;
    x1,y1,x2,y2:real;
begin
  y:=0;
 
  repeat
    x:=0;
 
    repeat
      z1 := funcXY(x,y,c1);              { zaciatocny bod }
      z2 := funcXY(x+KROK,y,c2);         { ciara vpravo   }
      if(c1 and c2 )then                 { ak sa da nakreslit }
         mline( x,y,z1, x+KROK,y,z2 );
 
      z2 := funcXY(x,y+KROK,c2);         { ciara nahor    }
      if(c1 and c2 )then                 { ak sa da nakreslit }
         mline( x,y,z1, x,y+KROK,z2 );
 
      x:=x+KROK;
    until (x>=(GetMaxX/2));
 
    y:=y+KROK;
  until (y>=(GetMaxY/3));
end;
 
 
{ vypise uvodny help }
procedure Help;
begin
  writeln('Graf viewer');
  writeln('-----------');
  writeln('1,2           - otacanie v osi x');
  writeln('3,4           - otacanie v osi y');
  writeln('5,6           - otacanie v osi z');
  writeln('Vlavo, Vpravo - zvacsovanie, zmensovanie osi x,y');
  writeln('Hore, Dole    - zvacsovanie, zmensovanie osi z');
  writeln('ESC           - koniec');
  writeln('-------------------------------------------------');
  writeln('Stlac klaves');
end;
 
 
{ vyziada od uzivatela funkciu }
procedure VyziadajFunc;
begin
  writeln;
  writeln('Zadaj funkciu ktoru mam zobrazovat');
  write('f(x,y)=');
  fnc:='sin(x+y)';
  readln(fnc);
end;
 
 
{ hlavny program }
begin
  Help;
  VyziadajFunc;
 
  { inicializacia grafickej karty }
  gd := Detect;
 
  RegisterBGIdriver(@egavga_dr);
  gd:=9;gm:=1;
 
  InitGraph(gd, gm,' ');
  if( GraphResult <> grOk )then
  begin
    WriteLn('Chyba pri inicalizacii grafickej karty. Asi chyba egavga.bgi.');
    halt(1);
  end;
 
  { uhly zobrazenia 3D os kriza }
  alpha1:=0;
  beta1 :=135;
 
  alpha:=2.5;
  beta :=25.0;
  gama :=12.5;
  delta:=0.0;
 
  { definujeme koncove body }
  x_zac := 0;
  y_zac := 0;
  z_zac := 0;
  x_kon := 10;
  y_kon := 10;
  z_kon := 10;
 
  xo:=200;
  yo:=250;
 
  { pre zaciatok }
  ch:=#10;
 
  repeat
    { zvacseni, zmensenie grafu }
    if( ch='P' )then begin
                      x_zac:=x_zac*2; x_kon:=x_kon*2;
                      y_zac:=y_zac*2; y_kon:=y_kon*2;
                      z_zac:=z_zac*2; z_kon:=z_kon*2;
                     end;
    if( ch='H' )then begin
                      x_zac:=x_zac/2; x_kon:=x_kon/2;
                      y_zac:=y_zac/2; y_kon:=y_kon/2;
                      z_zac:=z_zac/2; z_kon:=z_kon/2;
                     end;
 
    { otacenie osi z }
    if( ch='1' )then alpha:=alpha-KU;
    if( ch='2' )then alpha:=alpha+KU;
 
    if( ch='3' )then beta:=beta-KU;
    if( ch='4' )then beta:=beta+KU;
 
    if( ch='5' )then gama:=gama-KU;
    if( ch='6' )then gama:=gama+KU;
 
    if( ch='7' )then delta:=delta-KU;
    if( ch='8' )then delta:=delta+KU;
 
    ClearDevice;
    OsKriz;
    KresliGraf;
 
    ch := readkey;
    { precitame sede klavesy }
    if( ch=#0 )then ch:=readkey;
 
  until (ch = #27); {ESC}
 
  { zatvorime graficku kartu }
  CloseGraph;
end.