Umiestnenie súboru www.TrSek.com/cover/neznamy/rotacia_kocky.pas{ 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;
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;
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;
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;
{ 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;
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);
{ 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. }