Jednoduchá 3D rotácia kocky s jednoduchým vyhladzovaním hrán (antialiasingom) a tieňovaním

{ ROTACIA_KOCKY.PAS                                                 }
{ Jednoducha 3D rotacia kocky s jednoduchym vyhladzovanim hran      }
{ (antialiasingom) a tienovanim. Ovladanie pomocou klavesnice.      }
{                                                                   }
{ Author: Unknown                                                   }
{ Datum: 23.02.2009                            http://www.trsek.com }
 
program ROTACIA_KOCKY;
uses Crt;
 
type bod = record
       x,y,z:real;
     end;
     stena = record
       a,b,c,d: integer;
       poradie: integer;
       max_y,min_y:real;
       privratena:boolean;
     end;
     TBitmap = array [0..199,0..319] of byte;
 
var
  screen: TBitmap absolute $A000:0; { priamy pristup do pamate grafickej karty }
  pocetVrcholov, pocetHran, pocetStien: integer;
  vrcholy: array [1..100] of bod;
  steny: array [1..100] of stena;
 
  side: array[0..3] of integer; { pole, kde sa ukladaju pozicie bocnych stien }
  buf: array[0..3,0..1279] of byte; { jeden riadok obrazovky (320x1) ale 4x vacsi }
  y_pos: integer; { ktory riadok sa momentalne spracovava }
 
{ Nastavi farbu c na RGB hodnotu }
procedure SET_COLOR(r,g,b,c:byte);
begin
  port[$3C8]:=c;
  port[$3C9]:=r;
  port[$3C9]:=g;
  port[$3C9]:=b;
end;
 
{ Vykresli riadok y na obrazovku tak, ze spriemeruje 4x4 pixely z pola buf }
procedure VYKRESLI(y:integer);
var
  x:integer;
  i,j:integer;
  s:integer;
begin
  for x:=0 to 319 do begin
    s:=0;
    for i:=0 to 3 do
      for j:=0 to 3 do begin
        s:=s+buf[j,(x SHL 2)+i]; { x SHL 2 je vlastne x*4 ale rychlejsie }
      end;
    screen[y,x]:=s SHR 4; { s div 16 }
  end;
end;
 
 
procedure MODE(mode: byte);
begin
 ASM
  mov ah,0
  mov al,mode
  int $10
 end;
end;
 
 
{
procedure POINT(x,y:word; f:byte);
begin
 inc(x,640);
 inc(y,400);
 if (x<0)or(y<y_pos)or(x>=1280)or(y>=y_pos+4) then exit;
 buf[(y-y_pos),x]:=f;
end;
}
 
{ Vzdy kreslime iba jeden riadok skutocnej obrazovky, to su 4 riadky virtualnej 4x vacsej.
Preto pole side a aj pole buf ma vysku iba 4 }
 
{ Nastavi okrajovu tabulku na default hodnoty }
procedure CLEAR_SIDE;
begin
  side[0]:=-1;
  side[1]:=-1;
  side[2]:=-1;
  side[3]:=-1;
end;
 
{ Vykresli okraj strany. Ak uz je to druha cast, tak ju spoji ciarou s predchadzajucou }
procedure POINT2(x,y:word; f:byte);
var
  x1,x2:integer;
begin
 inc(x,640);
 inc(y,400);
 if (x<0)or(y<y_pos)or(x>=1280)or(y>y_pos+3) then exit;
 dec(y,y_pos);
 if(side[y]>=0) then begin
   x1:=x;
   x2:=side[y];
   if(x2<x1) then begin
     x1:=side[y];
     x2:=x;
   end;
   side[y]:=x;
   for x:=x1 to x2 do
     if buf[y,x]<f then buf[y,x]:=f;
 end else side[y]:=x;
end;
 
 
{
procedure USECKA(x1,y1,x2,y2:integer; f:byte);
var
  dx, dy, P, DP1, DP2, krok, pom, x, y: integer;
  vymena: boolean;
begin
  if(y1+400<y_pos)and(y2+400<y_pos) then exit;
  if(y1+400>y_pos+3)and(y2+400>y_pos+3) then exit;
 
  vymena:=false;
 
 
  if abs(y2-y1) > abs(x2-x1) then
    begin
      vymena:=true;
      pom:=x1; x1:=y1; y1:=pom;
      pom:=x2; x2:=y2; y2:=pom;
    end;
 
  if x2<x1 then
    begin
      pom:=x1; x1:=x2; x2:=pom;
      pom:=y1; y1:=y2; y2:=pom;
    end;
 
  if y2<y1 then
    krok:= -1
  else
    krok:= 1;
 
 
  dx:= x2-x1;
  dy:= abs(y2-y1);
  P:= 2*dy-dx;
  DP1:= 2*dy;
  DP2:= 2*dy-2*dx;
 
  while x1 < x2+1 do
  begin
    if vymena then
      POINT(y1,x1,f)
    else
      POINT(x1,y1,f);
 
    if P > 0 then
      begin
       p:= p + DP2;
       y1:= y1 + krok;
      end
    else
      p:= p + DP1;
    inc(x1);
  end;
end;
}
 
procedure USECKA2(x1,y1,x2,y2:integer; f:byte);
var
  dx, dy, P, DP1, DP2, krok, pom, x, y: integer;
  vymena: boolean;
begin
  { Ak je usecka mimo momentalne vykreslovaneho riadku, tak ihned skonci }
  if(y1+400<y_pos)and(y2+400<y_pos) then exit;
  if(y1+400>y_pos+3)and(y2+400>y_pos+3) then exit;
 
  vymena:=false;
 
  if abs(y2-y1) > abs(x2-x1) then
    begin
      vymena:=true;
      pom:=x1; x1:=y1; y1:=pom;
      pom:=x2; x2:=y2; y2:=pom;
    end;
 
  if x2<x1 then
    begin
      pom:=x1; x1:=x2; x2:=pom;
      pom:=y1; y1:=y2; y2:=pom;
    end;
 
  if y2<y1 then
    krok:= -1
  else
    krok:= 1;
 
 
  dx:= x2-x1;
  dy:= abs(y2-y1);
  P:= 2*dy-dx;
  DP1:= 2*dy;
  DP2:= 2*dy-2*dx;
 
  while x1 < x2+1 do
  begin
    if vymena then
      POINT2(y1,x1,f)
    else
      POINT2(x1,y1,f);
 
    if P > 0 then
      begin
       p:= p + DP2;
       y1:= y1 + krok;
      end
    else
      p:= p + DP1;
    inc(x1);
  end;
end;
 
 
procedure NACITANIE;
var
 f: text;
 i:integer;
begin
 assign(f,'vstup.txt');
 reset(f);
 readln(f,pocetVrcholov);
 for i:=1 to pocetVrcholov do
   begin
    read(f,vrcholy[i].x);
    read(f,vrcholy[i].y);
    readln(f,vrcholy[i].z);
    vrcholy[i].x:=vrcholy[i].x*6;
    vrcholy[i].y:=vrcholy[i].y*6;
    vrcholy[i].z:=vrcholy[i].z*6;
   end;
 readln(f,pocetStien);
 for i:= 1 to pocetStien do
   begin
    read(f,steny[i].a);
    read(f,steny[i].b);
    read(f,steny[i].c);
    readln(f,steny[i].d);
    steny[i].poradie:=i;
   end;
 close(f);
end;
 
 
 
procedure POSUNUTIE(posun: integer; smer: char);
var
  i:integer;
begin
 for i:=1 to pocetVrcholov do
   begin
    case smer of
      'l': vrcholy[i].x:= vrcholy[i].x - posun;
      'r': vrcholy[i].x:= vrcholy[i].x + posun;
      'u': vrcholy[i].y:= vrcholy[i].y - posun;
      'd': vrcholy[i].y:= vrcholy[i].y + posun;
      '+': begin
            vrcholy[i].x:= vrcholy[i].x * 1.01;
            vrcholy[i].y:= vrcholy[i].y * 1.01;
            vrcholy[i].z:= vrcholy[i].z * 1.01;
           end;
      '-': begin
            vrcholy[i].x:= vrcholy[i].x / 1.01;
            vrcholy[i].y:= vrcholy[i].y / 1.01;
            vrcholy[i].z:= vrcholy[i].z / 1.01;
           end;
    end;
   end;
end;
 
 
{
procedure VYPLN(i: integer);
var x: array[0..3] of integer;
    y: array[0..3] of integer;
    pom, k, kk: integer;
    k12, k32, k34, k14: real;
    xxx1,xxx2: real;
begin
 x[0]:= round(vrcholy[steny[i].a].x);
 y[0]:= round(vrcholy[steny[i].a].y);
 x[1]:= round(vrcholy[steny[i].b].x);
 y[1]:= round(vrcholy[steny[i].b].y);
 x[2]:= round(vrcholy[steny[i].c].x);
 y[2]:= round(vrcholy[steny[i].c].y);
 x[3]:= round(vrcholy[steny[i].d].x);
 y[3]:= round(vrcholy[steny[i].d].y);
 
 maxY:= y[0];
 kk:= 0;
 
 for k:= 1 to 3 do
  begin
   if y[k] > maxY then
    begin
     pom:= y[k];
     y[k]:= maxY;
     maxY:= pom;
     kk:= k;
    end;
  end;
 
 if y[(kk+1) mod 4] > y[(kk-1) mod 4] then
   begin
    pom:= y[(kk+1) mod 4];
    y[(kk+1) mod 4]:= y[(kk-1) mod 4];
    y[(kk-1) mod 4]:= pom;
    pom:= x[(kk+1) mod 4];
    x[(kk+1) mod 4]:= x[(kk-1) mod 4];
    x[(kk-1) mod 4]:= pom;
   end;
 
 yy2:= y[kk];
 xx2:= x[kk];
 yy3:= y[(kk+1) mod 4];
 xx3:= x[(kk+1) mod 4];
 yy1:= y[(kk-1) mod 4];
 xx1:= x[(kk-1) mod 4];
 yy4:= y[(kk+2) mod 4];
 xx4:= x[(kk+2) mod 4];
 
 if (yy3 - yy2) = 0 then
   k32:= 0
 else
   k32:= (xx3 - xx2) / (yy3 - yy2);
 
 if (yy1 - yy2) = 0 then
   k12:= 0
 else
   k12:= (xx1 - xx2) / (yy1 - yy2);
 
 if (yy3 - yy4) = 0 then
   k34:= 0
 else
   k34:= (xx3 - xx4) / (yy3 - yy4);
 
 
 if (yy1 - yy4) = 0 then
   k14:= 0
 else
   k14:= (xx1 - xx4) / (yy1 - yy4);
 
 
 xxx1:= xx2;
 xxx2:= xx2;
 
 for y:= yy2 downto y3 do
   begin
    USECKA(round(xxx1),y,round(xxx2),y,7);
    xxx1:= xxx1 + k32;
    xxx2:= xxx2 + k12;
   end;
end;
}
 
 
procedure ROTACIA(uhol: real; os: char);
var
 v_x, v_y, v_z: real;  {vrcholy}
 c,s:real;
 i:integer;
begin
 uhol:= (uhol*Pi) / 180;
 c:=cos(uhol);
 s:=sin(uhol);
 for i:= 1 to pocetVrcholov do
   begin
    v_x:= vrcholy[i].x;
    v_y:= vrcholy[i].y;
    v_z:= vrcholy[i].z;
    case os of
      'x': begin
            vrcholy[i].x:= v_x;
            vrcholy[i].y:= c*v_y - s*v_z;
            vrcholy[i].z:= s*v_y + c*v_z;
           end;
      'y': begin
            vrcholy[i].x:= c*v_x + s*v_z;
            vrcholy[i].y:= v_y;
            vrcholy[i].z:= - s*v_x + c*v_z;
           end;
      'z': begin
            vrcholy[i].x:= c*v_x - s*v_y;
            vrcholy[i].y:= s*v_x + c*v_y;
            vrcholy[i].z:= v_z;
           end;
    end;
   end;
end;
 
 
 
function NORMALA_Z(a,b,c:bod):real;
var u,v,n: bod;
begin
 u.x:= a.x - b.x;
 u.y:= a.y - b.y;
 u.z:= a.z - b.z;
 
 v.x:= b.x - c.x;
 v.y:= b.y - c.y;
 v.z:= b.z - c.z;
 
 n.x:= u.y * v.z - u.z * v.y;
 n.y:= u.z * v.x - u.x * v.z;
 NORMALA_Z:= u.x * v.y - u.y * v.x;
end;
 
{ Vrati hodnotu normaly, ale normovanu, aby sa dala pouzit na farbu }
function NORMALA_Z2(a,b,c:bod):real;
var u,v,n: bod;
begin
 u.x:= a.x - b.x;
 u.y:= a.y - b.y;
 u.z:= a.z - b.z;
 
 v.x:= b.x - c.x;
 v.y:= b.y - c.y;
 v.z:= b.z - c.z;
 
 n.x:= u.y * v.z - u.z * v.y;
 n.y:= u.z * v.x - u.x * v.z;
 n.z:= u.x * v.y - u.y * v.x;
 NORMALA_Z2:= n.z*23/sqrt(n.z*n.z+n.x*n.x+n.y*n.y);
end;
 
 
function PRIVRATENA(s:integer): boolean;
begin
 if NORMALA_Z(vrcholy[steny[s].a],
              vrcholy[steny[s].b],
              vrcholy[steny[s].c]) > 0 then PRIVRATENA:= true
 else PRIVRATENA:= false;
end;
 
{ Urci farbu steny podla hodnoty uhla normaly }
function FARBA_STENY(s:integer):byte;
var
  r:real;
begin
  r:=NORMALA_Z2(vrcholy[steny[s].a],vrcholy[steny[s].b],vrcholy[steny[s].c]);
  FARBA_STENY:=trunc(r)+40;
end;
 
 
procedure VYKRESLI_STENY(i:integer);
var
  farba:byte;
begin
      farba:=FARBA_STENY(steny[i].poradie); { spocitanie farby }
      CLEAR_SIDE;
      USECKA2(round(vrcholy[steny[i].a].x), round(vrcholy[steny[i].a].y),
             round(vrcholy[steny[i].b].x), round(vrcholy[steny[i].b].y),farba);
 
      USECKA2(round(vrcholy[steny[i].b].x), round(vrcholy[steny[i].b].y),
             round(vrcholy[steny[i].c].x), round(vrcholy[steny[i].c].y),farba);
 
      USECKA2(round(vrcholy[steny[i].c].x), round(vrcholy[steny[i].c].y),
             round(vrcholy[steny[i].d].x), round(vrcholy[steny[i].d].y),farba);
 
      USECKA2(round(vrcholy[steny[i].d].x), round(vrcholy[steny[i].d].y),
             round(vrcholy[steny[i].a].x), round(vrcholy[steny[i].a].y),farba);
 
end;
 
{ Postupne po jednom riadku kresli celu scenu. Je to sice trochu pomale, ale
zato ovela jednoduchsie a efektivnejsie ako Jozove riesenie antialiasingu,
kedze sa to cele vojde do zakladnej pamate a netreba ziadne strankovanie.
Mal som v plane este trosku optimalizovat RENDERUJ, no uz som to nestihol :_( }
procedure RENDERUJ;
var
  y,i:integer;
  min,max:real;
begin
  { Kontrolu privratenosti strany som premiestnil sem. Spolu s tym si pre
  kazdu stenu vypocitam jej maximalne a minimalne y }
 
  for i:=1 to pocetStien do
    begin
      if PRIVRATENA(steny[i].poradie) then begin
        steny[i].privratena:=true;
        min:=vrcholy[steny[i].a].y;
        max:=vrcholy[steny[i].a].y;
        if(min>vrcholy[steny[i].b].y) then min:=vrcholy[steny[i].b].y;
        if(min>vrcholy[steny[i].c].y) then min:=vrcholy[steny[i].c].y;
        if(min>vrcholy[steny[i].d].y) then min:=vrcholy[steny[i].d].y;
        if(max<vrcholy[steny[i].b].y) then max:=vrcholy[steny[i].b].y;
        if(max<vrcholy[steny[i].c].y) then max:=vrcholy[steny[i].c].y;
        if(max<vrcholy[steny[i].d].y) then max:=vrcholy[steny[i].d].y;
        steny[i].max_y:=max+400;
        steny[i].min_y:=min+400;
      end
      else steny[i].privratena:=false;
    end;
 
  { Teraz to prejde zaradom vsetky riadky obrazovky a kazdy samostatne vykresli }
  for y:=0 to 199 do begin
    y_pos:=y SHL 2; { y_pos je virtualna pozicia na 4x vacsej obrazovke. y SHL 2 je to iste ako y*4 }
    FillChar(buf,SizeOf(buf),0); { vycistenie riadku, ktory sa prave spracovava }
    for i:=1 to pocetStien do begin
      { Teraz to vykresli vsetky steny, ktore su momentalne privratene a zaroven je ich cast
      v prave vykreslovanom riadku }
      if(steny[i].privratena)and(steny[i].min_y<=y_pos+3)and(steny[i].max_y>=y_pos) then
        VYKRESLI_STENY(i);
    end;
    { V skutocnosti si do pamate nekreslim jeden riadok, ale obrazok 4x vacsi. Procedure
    VYKRESLI teraz spracuje ten jeden 4x vacsi obrazok a zmensi ho tak, ze vzdy spriemeruje
    4x4 pixely. Toto je vlastne antialiasing. }
    VYKRESLI(y);
  end;
end;
 
var
  i:integer;
  klav: char;  {klavesa}
begin
 NACITANIE;
 MODE($13);
 
 for i:=1 to 63 do begin
   SET_COLOR(i,i,i,i);
 end;
 
 RENDERUJ;
 klav:= readkey;
 
 while klav <> 'p' do
   begin
     case klav of
       'a': begin ROTACIA(2,'x'); end;
       's': begin ROTACIA(2,'y'); end;
       'd': begin ROTACIA(2,'z'); end;
       'q': begin ROTACIA(-2,'x'); end;
       'w': begin ROTACIA(-2,'y'); end;
       'e': begin ROTACIA(-2,'z'); end;
       'j': begin POSUNUTIE(3,'l'); end;
       'l': begin POSUNUTIE(3,'r'); end;
       'i': begin POSUNUTIE(3,'u'); end;
       'k': begin POSUNUTIE(3,'d'); end;
       'm': begin POSUNUTIE(3,'+'); end;
       'n': begin POSUNUTIE(3,'-'); end;
      end;
     RENDERUJ;
     klav:= readkey;
   end;
 MODE($03);
end.
{ Prepac, viac som nestihol. Snad Ti aj toto trosku pomoze. }