{ 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(x2max_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=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; 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 } 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*33/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; 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); 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,z); USECKA2(round(vrcholy[steny[i].c].x), round(vrcholy[steny[i].c].y), round(vrcholy[steny[i].a].x), round(vrcholy[steny[i].a].y),farba,z); end; 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_y255 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.