Трехмерная фигура

program spo;
type
 ar=array [0..64000] of byte;
 ara=array [1..12] of array[1..2] of byte;
var
 h,xcentro,ycentro,yelb,yro,xro,zro:integer;
 color:byte;
 ch:Boolean;
 alfax,alfay,alfaz,uglr:real;
 ae:word;
 ar1:ar;
 arcl,arch,arcr:ara;
 
{прорисовка_точек_массива__________}
procedure pix;
begin
 asm
      mov ax,13h
      int 10h
      mov ax,$a0000 {режим видеоадаптера}
      mov es,ax
      
      lea si,ar1 {загрузка адреса массива}
      
      mov cx,$fa00
 
@l: lodsb
 
      mov di,cx {координаты точки}
      mov [es:di],al
 
      loop @l
 
      xor ah,ah
{      int16h} Лучше эту строку оставить закоментированной, на современных машинах и машинах ИжГТУ анимации не будет
из-за того, что каждый кадр долго прорисовывается.
 end;
end;
{________________________________}
 
{_____процедура_очистки_экрана___}
procedure black;
var
 bl:word;
begin
 bl:=0;
 color:=0;
 while bl<=64000 do
 begin
  ar1[bl]:=color;
  bl:=bl+1;
 end;
end;
{_______________________________}
 
{_______________________________}
procedure rotation (xa,ya,za:integer);
var
 x1,y1,z1,x2,y2,z2:integer;
 bex,bey,bez:real;
begin
 bex:=alfax*3.14/180;
 bey:=alfay*3.14/180;
 bez:=alfaz*3.14/180;
 
 xa:=xa-160;
 ya:=ya-100;
 za:=za;
 
{поворот XY}
 
 x1:=round(xa*cos(bez)+ya*sin(bez));
 y1:=round(xa*sin(bez)-ya*cos(bez));
 
{поворот ZY}
 
 z1:=round(za*cos(bex)+ya*sin(bex));
 y2:=round(za*sin(bex)-ya*cos(bex));
 
{поворот XZ}
 
 x2:=round(x1*cos(bey)+z1*sin(bey));
 z2:=round(x1*sin(bey)-z1*cos(bey));
 
{output}
 
 xro:=160+x2;
 yro:=100+y2;
 zro:=z2;
 
end;
{________________________________}
 
procedure arc(r:integer);
var
 xn,yn,zn,xa,ya,za,xb,yb,xc,yc,zc:integer;
 be,al,ugl,mu:real;
 i:=word;
begin
 xn:=r;
 yn:=0;
 zn:=h;
 
 xc:=110;
 yc:=100;
 zc:=h;
 
 rotation (xc,yc,zc);
 
 xc:=xro;
 yc:=yro;
 
 xcentro:=xc;
 ycentro:=yc;
 
 al:=0;
 while al<+360 do
 begin
  be:=al*3.14/180;
  
  xa:=110+round(xn*cos(be)+yn*sin(be));
  ya:=100+round(xn*sin(be)-yn*cos(be));
  za:=zn;
 
  rotation (xa,ya,za);
  xb:=xro;
  yb:=yro;
 
  ae:=yb*320+xb;
  ar1[ae]:=color;
 
  al:=al+1;
 end;
 
 ugl:=360/12+uglr;
 i:=1;
 while ugl<=(uglr+360) do
 begin
  mu:=ugl*3.14/180;
  xa:=110+round(xn*cos(mu)+yn*sin(mu));
  ya:=100+round(xn*sin(mu)-yn*cos(mu));
  za:=zn;
 
  rotation (xa,ya,za);
  xa:=xro;
  ya:=yro;
 
  arcl[i,1]:=xa;
  arcl[i,2]:=ya;
 
  ae:=ya*320+xa;
  ar1[ae]:=color;
  ugl:=ugl+360/12;
 
  i:=i+1;
 
 end;
end;
{___________________________}
 
{______________________________}
procedure line (x1,y1,x2,y2:integer);
var
 dx,dy,err,derr,flx,fly:integer;
 bx,by:boolean;
begin
 if x1<=x2 then {направление линии}
 bx:=true
 else bx:=false;
 
 if y1<=y2 then
 by:=true
 else
 by:=false; {}
 
 dx:=abs(x2-x1); {алгоритм Брезенхейма}
 dy:=abs(y2-y1);
 err:=0;
 flx:=x1;
 fly:=y1;
 
 if dx>dy then
 begin
  derr:dy;
  
  if bx=true then
  begin
   while flx<=x2 do
   begin
    ae:=320*fly+flx;
    ar1[ae]:=color;
 
    err:=err+derr;
    if 2*err>=dx then
    begin
     if by=true then fly:=fly+1
     else fly:=fly-1;
     err:=err-dx;
    end;
 
    flx:=flx+1;
   end;
  end;
 
  else
  begin
   while flx>=x2 do
   begin
    ae:=320*fly+flx;
    ar1[ae]:=color;
 
    err:=err+derr;
    if 2*err>=dx then
    begin
     if by=true then fly:=fly+1;
     else fly:=fly-1;
     err:=err-dx;
    end;
 
    flx:=flx-1;
   end;
  end;
 end
 {_____________}
 else
 begin
  derr:=dx;
 
  if by=true then
  begin
   while fly<=y2 do
   begin
    ae:=320*fly+flx;
    ar1[ae]:=color;
 
    err:err+derr;
    if 2*err>=dy then
    begin
     if bx=true then flx:=flx+1
     else flx:=flx-1;
     err:=err-dy;
    end;
 
    fly:=fly+1;
   end;
  end
 
  else
  begin
   while fle>=y2 do
   begin
    ae:=320*fly+flx
    ar1[ae]:=color;
 
    err:=err+derr;
    if 2*err>=dy then
    begin
     if bx=true then flx:=flx+1
     else flx:=flx-1;
     err:=err-dy;
    end;
 
    fly:=fly-1;
   end;
  end;
 end;
 
end;
{______________________________________}
 
{______________________________________}
procedure arcline (xn,yn,zn,
                              xc,yc,zc,
                              xk,yk,zk:
                              integer; g:byte);
var
 xno,yno,zno,xko,yko,zko,xp,yp,xt,yt,zt,xo,yo,zo:integer;
 af,be,ga,de:real;
begin
 xno:=xn-xc; yno:=yn-yc; zno:=zn-zc;
 xko:=xk=xc; yko:=yk-yc; zko:=zk-zc;
 
 af:=0;
 
 zno:=-zno;
 zko:=-zko;
 while af<=360 do
 begin
  be:=-af*3.14/180;
 
  xo:=xno;
 
  ga:=0;
  while xo>xko do
  begin
   de:=ga*3.14/180;
 
   xo:=round(xno*cos(de)+zno*sin(de));
   yo:=yno;
   zo:=round(xno*sin(de)-zno*cos(de));
 
   xt:=xc+round(xo*cos(-be)+yo*sin(-be));
   yt:=yc+round(xo*sin(-be)-yo*cos(-be));
   zt:=zc+zo;
 
   rotation (xt,yt,zt);
 
   ae:=320*yro+xro;
   ar1[ae]:=color;
 
   if g=2 then ga:=ga+1
   else ga:=ga-1;
  end;
  af:=af+30;
 end;
end;
{______________________________________}
 
{______________________________________}
procedure cilindr;
var
 xf,yf,zfn,zfc,zfk:integer;
 i:=word;
begin
 color:=15;
 
{1}
 h:=95;
 arc(0);
 xf:=xcentro;
 yf:=ycentro;
 
{2}
 h:=55;
 arc(15);
 i:=1;
 while i<=12 do
 begin
  line(xf,yf,arcl[i,1],arcl[i,2]);
 
  arch[i,1]:=arcl[i,1];
  arch[i,2]:=arcl[i,2];
 
  i:=i+1;
 end;
 
{3}
 h:=55;
 arc(30);
 i:=1;
 while i<=12 do
 begin
  line(arch[i,1],arch[i,2],arcl[i,1],arcl[i,2]);
 
  arch[i,1]:=arcl[i,1];
  arch[i,2]:=arcl[i,2];
 
  i:=i+1;
 end;
 
{4}
 h:=-65;
 arc(30);
 xf:=xcentro;
 yf:=ycentro;
 zfc:=h;
 i:=1;
 while i<=12 do
 begin
  line(xf,yf,arcl[i,1],arcl[i,2]);
 
  line(arch[i,1],arch[i,2],arcl[i,1],arcl[i,2]);
 
  i:=i+1;
 end;
 
{5}
 h:=-40;
 arc:=20;
 zfn:=h;
 i:=1;
 while i<=12 do
 begin
  line(xf,yf,arcl[i,1],arcl[i,2]);
 
  arch[i,1]:=arcl[i,1];
  arch[i,2]:=arcl[i,2];
 
  i:=i+1;
 end;
 
{6}
 h:=-33;
 arc(0);
 zfk:=h;
 
 arcline(130,100,zfn,
             110,100,zfc,
             110,100,zfk,
             2);
end;
{______________________________________}
 
{main program}
begin
 uglr:=0;
 alfax:=45;
 alfay:=0;
 alfaz:=0;
 
 while alfay<=3600 do
 begin
  cilindr;
  pix;
  black;
 
  alfay:=alfay+15;
  uglr:=uglr+7;
 end;
end.

procedure rotation(var xa,ya,za:integer;ax,ay,az:integer);
var x1,y1,z1,x2,y2,z2:real;
    bex, bey, bez:real;
begin
  bex:=ax*pi/180;bey:=ay*pi/180;bez:=az*pi/180;
  x1:=(xa*cos(bez)+ya*sin(bez));
  y1:=(xa*sin(bez)-ya*cos(bez));
  z1:=(za*cos(bex)+ya*sin(bex));
  y2:=(za*sin(bex)-ya*cos(bex));
  x2:=(x1*cos(bey)+z1*sin(bey));
  z2:=(x1*sin(bey)-z1*cos(bey));
  xa:=round(x2);ya:=round(y2);za:=round(z2);
end;

repeat
  for x:=0 downto -24 do
    begin
      xx:=round(20*cos(x/180*pi*15));
      yy:=round(20*sin(x/180*pi*15));
      zz:=0;
      clr;{}
      DrawObelisk(xx,yy,zz, 0,0,0, 15);{}
      DrawPir(xx,yy,zz, 0,0,0, 15);{}
      DrawUK(xx,yy,zz, 0,0,0,  15);{}
      {buf:=buf1;{}
      Delay(100);
   end;
until keypressed;