Umiestnenie súboru www.TrSek.com/cover/neznamy/rotacia_cokolvek.pas{ BEZIER-BSPLINE.PAS }
{ Jednoduche 3D zobrazenie modelu nacitaneho zo suboru. Viditelnost }
{ je riesena len na zaklade privratenych a odvratenych stran(normal).}
{ Model je mozne otacat, posuvat a priblizovat pomocou klavesnice. }
{ }
{ Author: Unknown }
{ Datum: 23.02.2009 http://www.trsek.com }
program ROTACIA_COHOKOLVEK;
uses Crt,dos;
type bod = record
x,y,z:real;
end;
stena = record
a,b,c: integer;
z:byte;
poradie: integer;
max_y,min_y:integer;
visible:boolean;
end;
TBitmap = array [0..49,0..319] of byte;
var
pocetVrcholov, pocetHran, pocetStien: integer;
vrcholy: array [1..700] of bod;
steny: array [1..1400] of stena;
side: array[0..49] of integer;
screen1: TBitmap absolute $A000:0;
screen2: TBitmap absolute $A000:16000;
screen3: TBitmap absolute $A000:32000;
screen4: TBitmap absolute $A000:48000;
buf: array[0..49,0..319] of byte;
zbuf: array[0..49,0..319] of byte;
min_y,max_y:integer;
procedure SET_COLOR(r,g,b,c:byte);
begin
port[$3C8]:=c;
port[$3C9]:=r;
port[$3C9]:=g;
port[$3C9]:=b;
end;
procedure MODE(mode: byte);
begin
ASM
mov ah,0
mov al,mode
int $10
end;
end;
procedure CLEAR_SIDE;
var
i:integer;
begin
for i:=0 to 49 do begin
side[i]:=-1;
end;
end;
procedure POINT2(x,y:integer; f,z:byte);
var
x1,x2:integer;
begin
inc(x,160);
inc(y,100-min_y);
if (x<0)or(y<0)or(x>=320)or(y>49) then exit;
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 begin
if zbuf[y,x]<=z then begin
buf[y,x]:=f;
zbuf[y,x]:=z;
end;
end;
end else begin
side[y]:=x;
end;
end;
procedure USECKA2(x1,y1,x2,y2:integer; f,z:byte);
var
dx, dy, P, DP1, DP2, krok, pom, x, y: integer;
vymena: boolean;
bol_dnu:boolean;
je_dnu:boolean;
begin
if(y1+100<min_y)and(y2+100<min_y) then exit;
if(y1+100>max_y)and(y2+100>max_y) then exit;
vymena:=false;
bol_dnu:=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 begin
if(x1+100>=min_y)and(x1+100<=max_y) then je_dnu:=true
else je_dnu:=false;
if je_dnu then POINT2(y1,x1,f,z);
end
else begin
if(y1+100>=min_y)and(y1+100<=max_y) then je_dnu:=true
else je_dnu:=false;
if je_dnu then POINT2(x1,y1,f,z);
end;
if(je_dnu) then bol_dnu:=true;
if(bol_dnu=true)and(je_dnu=false) then exit;
if P > 0 then
begin
p:= p + DP2;
y1:= y1 + krok;
end
else
p:= p + DP1;
inc(x1);
end;
end;
procedure NACITANIE(nazov:string);
var
f: text;
i:integer;
begin
assign(f,nazov);
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;
vrcholy[i].y:=vrcholy[i].y;
vrcholy[i].z:=vrcholy[i].z;
end;
readln(f,pocetStien);
for i:= 1 to pocetStien do
begin
read(f,steny[i].a);
read(f,steny[i].b);
readln(f,steny[i].c);
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 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;
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;
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)+30;
end;
procedure VYKRESLI_STENY(i:integer;z:byte);
var
farba:byte;
begin
farba:=FARBA_STENY(steny[i].poradie);
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,z);
procedure RENDERUJ;
var
i,z:integer;
begin
for i:=1 to pocetStien do
begin
if PRIVRATENA(steny[i].poradie) then begin
steny[i].visible:=true;
min_y:=trunc(vrcholy[steny[i].a].y);
max_y:=trunc(vrcholy[steny[i].a].y);
if(min_y>trunc(vrcholy[steny[i].b].y)) then min_y:=trunc(vrcholy[steny[i].b].y);
if(min_y>trunc(vrcholy[steny[i].c].y)) then min_y:=trunc(vrcholy[steny[i].c].y);
if(max_y<trunc(vrcholy[steny[i].b].y)) then max_y:=trunc(vrcholy[steny[i].b].y);
if(max_y<trunc(vrcholy[steny[i].c].y)) then max_y:=trunc(vrcholy[steny[i].c].y);
{ if(z<trunc(vrcholy[steny[i].b].z)) then z:=trunc(vrcholy[steny[i].b].z);
if(z<trunc(vrcholy[steny[i].c].z)) then z:=trunc(vrcholy[steny[i].c].z);}
z:=z+128;
if z<0 then z:=0;
if z>255 then z:=255;
steny[i].z:=255-z;
end else steny[i].visible:=false;
end;
FillChar(buf,sizeof(buf),0);
FillChar(zbuf,sizeof(zbuf),0);
min_y:=50;max_y:=99;
for i:=1 to pocetStien do
begin
if (steny[i].visible)and((steny[i].min_y<=max_y)and(steny[i].max_y>=min_y)) then VYKRESLI_STENY(i,steny[i].z);
end;
move(buf,screen2,sizeof(buf));
FillChar(buf,sizeof(buf),0);
FillChar(zbuf,sizeof(zbuf),0);
min_y:=100;max_y:=149;
for i:=1 to pocetStien do
begin
if (steny[i].visible)and((steny[i].min_y<=max_y)and(steny[i].max_y>=min_y)) then VYKRESLI_STENY(i,steny[i].z);
end;
move(buf,screen3,sizeof(buf));
end;
var
i,c:integer;
klav:char;
DirInfo: SearchRec;
nazov:string;
begin
i:=1;
FindFirst('*.txt',Archive,DirInfo);
while DosError = 0 do
begin
Writeln(i,' : ',DirInfo.Name);
FindNext(DirInfo);
inc(i);
end;
if(i<=1) then begin
writeln('Nenasiel som ani jeden model!');
halt(1);
end;
write('Napis cislo modelu : ');
readln(c);
if(c<1)or(c>=i) then exit;
i:=1;
FindFirst('*.txt',Archive,DirInfo);
while DosError = 0 do
begin
if(i=c) then begin
NACITANIE(DirInfo.name);
c:=0;
break;
end;
FindNext(DirInfo);
inc(i);
end;
if(c<>0) then exit;
MODE($13);
for i:=1 to 63 do begin
SET_COLOR(0,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.