Jednoduché 3D zobrazenie modelu načítaného zo súboru

{ 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;
 
  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 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;
 
 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_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);
 
        steny[i].max_y:=max_y+100;
        steny[i].min_y:=min_y+100;
 
        z:=trunc(vrcholy[steny[i].a].z);
        z:=z+trunc(vrcholy[steny[i].b].z);
        z:=z+trunc(vrcholy[steny[i].b].z);
 
{        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.