{Jozef Sivek ml. december 2004 - januar 2004
priame premietanie priestorovych objektov na plochu, inak
taka hracka., budem sa chvastat; urobil som to za 5 hodin, ha, ha ... pravdaze len jadro ~ 250 riadkov

ale teraz asi vazne
program sluzi na studium funkcii 2 premennych v 3 suradnicovych sustavach
to co muozte editovat su procedury:
defin_fx - definicia hranic
fx       - samotna funkcia
}
program _3dfunkcionalna_analyza;
uses Graph,crt;

const top=58;

type    pole_v=array[1..3] of real;
        pole_v_int=array[1..2] of integer;
        baza=array[1..3] of pole_v;

        pole=array[0..top,0..top] of pole_v;{matrica grafu}
        pole_screen=array[0..top,0..top] of pole_v_int;

var
 Gd, Gm: Integer;
 maxxdiv2,maxydiv2,maxx:word;{graficke rozlisenie delene dvomi a nedelene}
 input_key:char;

 core:baza;{hl baza}
 p:baza;{baza pozorovatela, 1 je dopredu, 2 je doprava a 3 je hore voci pozorovatelovy}


 alfa,beta:real;{uhol v rad, alfa h, beta v}
 movev_const:real;{pohybova konstanta}

 m:pole;{graf}

 tip_sustavy:byte;{kartezianska, cylindricka alebo polarna}
		  {sory tip ma byt typ ale, nechce sa mi to uz prepisovat}
 x,y,z:pole_v;{ohranicenia zobrazenia grafu v kartezskych suradniciach}
 fi_2,r_2,z_2:pole_v;{ohranicenia zobrazenia grafu v cylindrikych suradniciach}
 fi_3,r_3,theta_3:pole_v;{ohranicenia zobrazenia grafu v polarnych suradniciach
                          theta sa pocita od zvislice

                          pravdaze uli su v rad!!!
                         }
 no:pole_v_int;{pocet segmentov }

 mierka:word;{pocet pixelov na jednotku dzky}


 tipe_of_rendering:byte;
 show_xyz:boolean;

 {color management}
 g_color:byte;
 g_color_xyz:byte;
 g_color_txt:byte;

 {animation management}
 motion_time:word;


 label citaj;{skok pre znovunacitanie klavese}

function fx(x,y:real):real;
         begin
         {takze tu si muozte vsetko, volny priestor pre experintovanie}
         case tip_sustavy of
         1: fx:=cos(sqrt(sqr(x*11)+sqr(y*10)))/9;
         2: fx:={sin(y*5)/3}sqrt(abs(1-sqr(y-1)));{x je teraz fi a y~r_2}
         3: fx:=arctan(x);{x je teraz fi a y~r_3}
         end;

         {fx:=sqrt(abs(1 - sqrt(sqr(x)+sqr(y)) ));}
         end;

procedure define_fx;
          begin
          tip_sustavy:=3;

          case tip_sustavy of
          1: begin
             x[1]:=-1.5;x[2]:=1.5;
             y[1]:=-1.5;y[2]:=1.5;
             z[1]:=-40;z[2]:=40;
             end;

          2: begin
             fi_2[1]:=0;fi_2[2]:=pi*2;
             r_2[1]:=0;r_2[2]:=2;
             z_2[1]:=-40;z_2[2]:=40;
             end;

          3: begin
             fi_3[1]:=0;fi_3[2]:=2*pi;
             r_3[1]:=0;r_3[2]:=1;
             theta_3[1]:=1;theta_3[2]:=2;
             end;

          end;

          end;

procedure solve;
          var osx,osy:integer;
              px,py:real;

          begin
          for osy:=0 to (no[2]-1) do begin
              case tip_sustavy of
              1: py:=y[1] + abs(y[1]-y[2]) * osy/(no[2]-1);
              2: py:=r_2[1] + abs(r_2[1]-r_2[2]) * osy/(no[2]-1);{py je teraz r}
              3: py:=r_3[1] + abs(r_3[1]-r_3[2]) * osy/(no[2]-1);{py je teraz r}
              end;

              for osx:=0 to (no[1]-1) do begin
                     case tip_sustavy of
                     1: px:=x[1] + abs(x[1]-x[2]) * osx/(no[1]-1);
                     2: px:=fi_2[1] + abs(fi_2[1]-fi_2[2]) * osx/(no[1]-1);{px je teraz fi}
                     3: px:=fi_3[1] + abs(fi_3[1]-fi_3[2]) * osx/(no[1]-1);{px je teraz fi}
                     end;

                     m[osx,osy][1]:=px;
                     m[osx,osy][2]:=py;
                     m[osx,osy][3]:=fx(px,py);
                     {samotna transformazia do kartezskych suradnic prebiebieha v solve_point}

                     end;end;
          end;

procedure refresh;
          begin
          maxxdiv2:=getmaxx div 2;
          maxydiv2:=getmaxy div 2;
          maxx:=getmaxx;

          p[1][1]:=-1; p[1][2]:=0; p[1][3]:=0;
          p[2][1]:=0; p[2][2]:=1; p[2][3]:=0;
          p[3][1]:=0; p[3][2]:=0; p[3][3]:=1;

          core[1][1]:=1; core[1][2]:=0; core[1][3]:=0;
          core[2][1]:=0; core[2][2]:=1; core[2][3]:=0;
          core[3][1]:=0; core[3][2]:=0; core[3][3]:=1;

          alfa:=pi/20;
          beta:=alfa;
          movev_const:=0.1;

          mierka:=100;

          no[1]:=30;
          no[2]:=30;

          tipe_of_rendering:=1;
          show_xyz:=true;

          g_color:=2;
          g_color_xyz:=1;
          g_color_txt:=15;

          motion_time:=250;

          solve;

          end;

procedure spinh(input:integer);{rotacia pozorovatela v horizontalnej rovine, okolo O}
          var I,M:integer;
              v:baza;
              alfa_my:real;
          begin
          alfa_my:=input * alfa;
          for I:=1 to 3 do begin
                     v[I][1]:=p[I][1] * cos(alfa_my) - p[I][2] * sin(alfa_my);
                     v[I][2]:=p[I][1] * sin(alfa_my) + p[I][2] * cos(alfa_my);
                     v[I][3]:=p[I][3];
                           end;
          for I:=1 to 3 do begin
                   for M:=1 to 3 do p[I][M]:=v[I][M];
                           end;

          end;

procedure spinv(input:integer);{rotacia pozorovatela vo vertikalnej rovine, okolo O}
          var v:baza;
              I:integer;
              beta_my:real;
          begin
          beta_my:=input * beta;

          for I:=1 to 3 do
          v[3][I]:=cos(beta_my) * p[3][I] + sin(beta_my) * p[1][I];
          for I:=1 to 3 do
          v[1][I]:=cos(beta_my) * p[1][I] - sin(beta_my) * p[3][I];

          for I:=1 to 3 do begin
                           p[3][I]:=v[3][I];
                           p[1][I]:=v[1][I];
                           end;
          end;

procedure movev(input:integer);
          var osx,osy:integer;
          begin
          for osy:=0 to (no[2]-1) do
              for osx:=0 to (no[1]-1) do begin
                  m[osx,osy][3]:=m[osx,osy][3] + input * movev_const;
              end;
          end;

procedure init_g;
          begin
          gd:=detect;
          initgraph(gd,gm,'c:/bp/bgi');
          if graphresult <> grok then halt(1);
          {koniec inicializacie}
          end;

procedure close_g;
          begin
          Closegraph;
          end;

procedure draw_point(a:pole_v_int; color:byte);
          begin
          putpixel(a[1] + (maxxdiv2),(maxydiv2) - a[2],color);
          end;

procedure draw_line(a,b:pole_v_int; color:byte);
          begin
          setcolor(color);
          line(a[1] + (maxxdiv2),(maxydiv2) - a[2],b[1] + (maxxdiv2),(maxydiv2) - b[2]);
          end;

procedure draw_moveto(a:pole_v_int);
          begin
          moveto(a[1] + (maxxdiv2),(maxydiv2) - a[2]);
          end;

procedure draw_lineto(a:pole_v_int; color:byte);
          begin
          if abs(a[1])+abs(a[2]) < maxx then begin
                                             setcolor(color);
                                             lineto(a[1] + (maxxdiv2),(maxydiv2) - a[2]);
                                             exit;
                                             end;
          draw_moveto(a);
          end;

procedure write_onscreen(x,y:integer; input:string; color:byte);
          var ch:string;
          begin
          setcolor(color);
          SetTextStyle(DefaultFont, HorizDir, 1);
          outtextxy(x + (maxxdiv2),(maxydiv2) - y,input);
          end;


procedure solve_point(point:pole_v; var screen_point:pole_v_int);
          var real_point:pole_v;
              I,M:integer;
          begin
          case tip_sustavy of
               2: begin {transformacne vzorce do xyz}
                  for I:=1 to 3 do real_point[I]:=point[I];
                  point[1]:=cos(real_point[1]) * real_point[2];
                  point[2]:=sin(real_point[1]) * real_point[2];
                  point[3]:=real_point[3];
                  end;
               3: begin{tak isto}
                  for I:=1 to 3 do real_point[I]:=point[I];
                  point[1]:=sin(real_point[3]) * cos(real_point[1]) * real_point[2];
                  point[2]:=sin(real_point[3]) * sin(real_point[1]) * real_point[2];
                  point[3]:=cos(real_point[3]) * real_point[2];
                  end;
          end;


          for I:=1 to 3 do
          real_point[I]:=core[1][I]*point[1] + core[2][I]*point[2] + core[3][I]*point[3];
          {toto monstrum je ako keby nova moznost menenie priestoru}


          screen_point[1]:=round( mierka * (p[2][1] * real_point[1] + p[2][2] * real_point[2] + p[2][3] * real_point[3]));
          screen_point[2]:=round( mierka * (p[3][1] * real_point[1] + p[3][2] * real_point[2] + p[3][3] * real_point[3]));

          end;


procedure render_point(x,y,z:real; color:byte);
          var point:pole_v;
              screen_point:pole_v_int;
          begin
          point[1]:=x;
          point[2]:=y;
          point[3]:=z;

          solve_point(point,screen_point);

          draw_point(screen_point,color);
          end;

procedure render_line(x,y,z,x2,y2,z2:real; color:byte);
          var point:pole_v;
              screen_point,screen_point2:pole_v_int;
          begin
          point[1]:=x;
          point[2]:=y;
          point[3]:=z;
          solve_point(point,screen_point);

          point[1]:=x2;
          point[2]:=y2;
          point[3]:=z2;
          solve_point(point,screen_point2);

          draw_line(screen_point,screen_point2,color);
          end;

procedure render_xyz(a:real; ch:char);
          var x,y,z:string;
              px,py,pz:pole_v_int;
              point:pole_v;
              tip_sustavy_old:byte;
          begin
          tip_sustavy_old:=tip_sustavy;
          tip_sustavy:=1;

          render_line(-a/2,0,0, a,0,0  ,g_color_xyz);
          render_line(0,-a/2,0, 0,a,0  ,g_color_xyz);
          render_line(0,0,-a/2, 0,0,a  ,g_color_xyz);

          if ch='t' then begin
              point[1]:=a;point[2]:=0;point[3]:=0;
              solve_point(point,px);
              point[1]:=0;point[2]:=a;point[3]:=0;
              solve_point(point,py);
              point[1]:=0;point[2]:=0;point[3]:=a;
              solve_point(point,pz);

                      {dost nemotorne ale nenapada ma inak}
              if a<>1 then str(a:1:1,x);
              x:='x :'+x;

              if a<>1 then str(a:1:1,y);
              y:='y :'+y;

              if a<>1 then str(a:1:1,z);
              z:='z :'+z;

              write_onscreen(px[1],px[2],x,g_color_txt);
              write_onscreen(py[1],py[2],y,g_color_txt);
              write_onscreen(pz[1],pz[2],z,g_color_txt);
                         end;
          tip_sustavy:=tip_sustavy_old;
          end;


procedure render_fx(tip:byte);
          var osy,osx:integer;
              matica: pole_screen;

          begin

          for osy:=0 to (no[2]-1) do
              for osx:=0 to (no[1]-1) do begin
              case tip of
              0: begin
                 case tip_sustavy of
                 1: if ((z[1] < m[osx,osy][3]) and (m[osx,osy][3] < z[2])) then
                 render_point(m[osx,osy][1],m[osx,osy][2],m[osx,osy][3],g_color);

                 2: if ((z_2[1] < m[osx,osy][3]) and (m[osx,osy][3] < z_2[2])) then
                 render_point(m[osx,osy][1],m[osx,osy][2],m[osx,osy][3],g_color);

                 3: if ((theta_3[1] < m[osx,osy][3]) and (m[osx,osy][3] < theta_3[2])) then
                 render_point(m[osx,osy][1],m[osx,osy][2],m[osx,osy][3],g_color);
                 end;

                 end;
              1: begin
     {
              stary spuosob
              if ((z[1] < m[osx,osy][3]) and (m[osx,osy][3] < z[2])) then begin
     if osx<(no[1]-1) then
     render_line(m[osx,osy][1],m[osx,osy][2],m[osx,osy][3],  m[osx+1,osy][1],m[osx+1,osy][2],m[osx+1,osy][3],g_color);

     if osy<(no[2]-1) then
     render_line(m[osx,osy][1],m[osx,osy][2],m[osx,osy][3],  m[osx,osy+1][1],m[osx,osy+1][2],m[osx,osy+1][3],g_color);

                                                                          end;
     }
                 solve_point(m[osx,osy], matica[osx,osy])

                 end;
              end;

                                        end;
          case tip of {v pripade, ze sa kresli mriezka tak sa vykresli z pola matica
                      dufam, ze sa tim renderovanie zrychli aspon dvojnasobne
                      }
             1: begin
              for osy:=0 to (no[2]-1) do begin
              draw_moveto(matica[0,osy]);
              for osx:=0 to (no[1]-1) do begin
                          draw_lineto(matica[osx,osy],g_color)
                                         end;end;

              for osx:=0 to (no[1]-1) do begin
              draw_moveto(matica[osx,0]);
              for osy:=0 to (no[2]-1) do begin
                          draw_lineto(matica[osx,osy],g_color)
                                         end;end;

                end;
          end;

          end;

procedure clear_scene;
          begin
          clearviewport;
          end;

procedure render_scene;
          begin
           render_fx(tipe_of_rendering);
           if show_xyz then render_xyz(1.2,'t');

          end;

begin
write('= 3d f');
writeln('od Jozef Sivek (c)2004':50);
{help('t');}

{init}
init_g;

define_fx;
refresh;



repeat
clear_scene;

render_scene;

citaj:;
input_key:=readkey;

{dufam, ze to bude stacit}

   case input_key of
   #63{,#32}: begin refresh;solve; end;{F5,medzernik}

   #72: {otocka hore/spin up}spinv(1);
   #80: {otocka dole/spin down}spinv(-1);
   #77: {otocka vpravo/spin right}spinh(1);
   #75: {otocka vlavo/spin left}spinh(-1);

   #73: movev(1);{pg up}
   #81: movev(-1);{pg down}

   #45: begin dec(mierka,10);if mierka<1 then mierka:=2; end;{-}
   #43:inc(mierka,10);{+}

{editacia grafu}
   #110: begin  {n}
         if tip_sustavy=1 then begin
         begin dec(no[1],1);if no[1]<=1 then no[1]:=2; no[2]:=no[1]; solve; end;
                               end;
         if tip_sustavy<>1 then begin
         begin dec(no[1],1);if no[1]<=1 then no[1]:=2; solve; end;
                                end;
         end;
   #78:  begin  {N}
         if tip_sustavy=1 then begin
         begin inc(no[1],1);if no[1]>top then no[1]:=top; no[2]:=no[1]; solve; end;
                               end;
         if tip_sustavy<>1 then begin
         begin inc(no[1],1);if no[1]>top then no[1]:=top; solve; end;
                                end;
         end;
   #98: begin dec(no[2],1);if no[2]<=1 then no[2]:=2; solve; end;{b}
   #66: begin inc(no[2],1);if no[2]>top then no[2]:=top; solve; end;{B}
   {----------}

   #102: begin {f}
         if tipe_of_rendering=1 then tipe_of_rendering:=0
            else tipe_of_rendering:=1;
         end;
   #120,#121,#122: show_xyz:=not(show_xyz);{x,y,z - vypnutie osi}

   #103: begin inc(g_color);if g_color=16 then g_color:=0; end;{g - zmena farby}

   #109: begin{m ako motion}
         repeat
         clear_scene;
         spinh(1);
         render_scene;
         delay(motion_time);
         until keypressed;
         end;

   #27:Halt;{esc}

   else goto citaj;
   end;

until input_key=#27;
close_g;
end.